diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) Lennart Kolmodin + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,26 @@ +# binary-ext package # + +An alternate with typed errors for ``Data.Binary.Get`` monad from ``binary`` library. + +## Building binary-ext ## + +Here's how to get the latest version of the repository and build. + + $ git clone https://github.com/A1-Triard/binary-ext.git + $ cd binary-ext + $ stack build + +Run the test suite. + + $ stack test + +## Using binary-ext ## + +First: + + import Data.Binary.Put + import Data.Binary.Get.Ext + +and then use the ``Get`` and ``Put`` monads to serialize/deserialize. + +More information in the haddock documentation. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/binary-ext.cabal b/binary-ext.cabal new file mode 100644 --- /dev/null +++ b/binary-ext.cabal @@ -0,0 +1,94 @@ +name: binary-ext +version: 0.8.4.1 +license: BSD3 +license-file: LICENSE +author: Lennart Kolmodin +maintainer: Lennart Kolmodin, Don Stewart +homepage: https://github.com/kolmodin/binary +description: Efficient, pure binary serialisation using lazy ByteStrings. + Haskell values may be encoded to and from binary formats, + written to disk as binary, or sent over the network. + The format used can be automatically generated, or + you can choose to implement a custom format if needed. + Serialisation speeds of over 1 G\/sec have been observed, + so this library should be suitable for high performance + scenarios. +synopsis: Binary serialisation for Haskell values using lazy ByteStrings +category: Data, Parsing +stability: provisional +build-type: Simple +cabal-version: >= 1.8 +tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3 +extra-source-files: + README.md + +source-repository head + type: git + location: git://github.com/A1-Triard/binary-ext.git + +library + build-depends: base >= 4.5.0.0 && < 5, bytestring >= 0.10.2, containers, array, binary + hs-source-dirs: src + exposed-modules: Data.Binary.Get.Ext + , Data.Binary.Get.Ext.Internal + + other-modules: Data.Binary.Internal, + Data.Binary.FloatCast + if impl(ghc <= 7.6) + -- prior to ghc-7.4 generics lived in ghc-prim + build-depends: ghc-prim + + ghc-options: -O2 -Wall -fliberate-case-threshold=1000 + + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances + +-- Due to circular dependency, we cannot make any of the test-suites +-- depend on the binary library. Instead, for each test-suite, +-- we include the source directory of binary and build-depend on all +-- the dependencies binary has. + +test-suite qc + type: exitcode-stdio-1.0 + hs-source-dirs: src tests + main-is: QC.hs + other-modules: Action + , Arbitrary + , Data.Binary.Get.Ext + , Data.Binary.Get.Ext.Internal + , Data.Binary.Internal + , Data.Binary.FloatCast + build-depends: base >= 4.5.0.0 && < 5 + , binary + , bytestring >= 0.10.2 + , random>=1.0.1.0 + , test-framework + , test-framework-quickcheck2 >= 0.3 + , QuickCheck + + -- build dependencies from using binary source rather than depending on the library + build-depends: array, containers + ghc-options: -Wall -O2 -threaded + if impl(ghc <= 7.6) + -- prior to ghc-7.4 generics lived in ghc-prim + build-depends: ghc-prim + + +test-suite read-write-file + type: exitcode-stdio-1.0 + hs-source-dirs: src tests + main-is: File.hs + build-depends: base >= 4.5.0.0 && < 5 + , bytestring >= 0.10.2 + , Cabal + , binary + , directory + , filepath + , HUnit + + -- build dependencies from using binary source rather than depending on the library + build-depends: array, containers + ghc-options: -Wall + if impl(ghc <= 7.6) + -- prior to ghc-7.4 generics lived in ghc-prim + build-depends: ghc-prim diff --git a/src/Data/Binary/FloatCast.hs b/src/Data/Binary/FloatCast.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/FloatCast.hs @@ -0,0 +1,45 @@ + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Trustworthy #-} + +-- | This module was written based on +-- . +-- +-- Implements casting via a 1-elemnt STUArray, as described in +-- . +module Data.Binary.FloatCast + ( floatToWord + , wordToFloat + , doubleToWord + , wordToDouble + ) where + +import Data.Word (Word32, Word64) +import Data.Array.ST (newArray, readArray, MArray, STUArray) +import Data.Array.Unsafe (castSTUArray) +import GHC.ST (runST, ST) + +-- | Reinterpret-casts a `Float` to a `Word32`. +floatToWord :: Float -> Word32 +floatToWord x = runST (cast x) +{-# INLINE floatToWord #-} + +-- | Reinterpret-casts a `Word32` to a `Float`. +wordToFloat :: Word32 -> Float +wordToFloat x = runST (cast x) +{-# INLINE wordToFloat #-} + +-- | Reinterpret-casts a `Double` to a `Word64`. +doubleToWord :: Double -> Word64 +doubleToWord x = runST (cast x) +{-# INLINE doubleToWord #-} + +-- | Reinterpret-casts a `Word64` to a `Double`. +wordToDouble :: Word64 -> Double +wordToDouble x = runST (cast x) +{-# INLINE wordToDouble #-} + +cast :: (MArray (STUArray s) a (ST s), + MArray (STUArray s) b (ST s)) => a -> ST s b +cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0 +{-# INLINE cast #-} diff --git a/src/Data/Binary/Get/Ext.hs b/src/Data/Binary/Get/Ext.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Get/Ext.hs @@ -0,0 +1,650 @@ +{-# LANGUAGE CPP, RankNTypes, MagicHash, BangPatterns #-} +{-# LANGUAGE Trustworthy #-} + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +#include "MachDeps.h" +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary.Get.Ext +-- Copyright : Lennart Kolmodin +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Lennart Kolmodin +-- Stability : experimental +-- Portability : portable to Hugs and GHC. +-- +-- The 'Get' monad. A monad for efficiently building structures from +-- encoded lazy ByteStrings. +-- +-- Primitives are available to decode words of various sizes, both big and +-- little endian. +-- +-- Let's decode binary data representing illustrated here. +-- In this example the values are in little endian. +-- +-- > +------------------+--------------+-----------------+ +-- > | 32 bit timestamp | 32 bit price | 16 bit quantity | +-- > +------------------+--------------+-----------------+ +-- +-- A corresponding Haskell value looks like this: +-- +-- @ +--data Trade = Trade +-- { timestamp :: !'Word32' +-- , price :: !'Word32' +-- , qty :: !'Word16' +-- } deriving ('Show') +-- @ +-- +-- The fields in @Trade@ are marked as strict (using @!@) since we don't need +-- laziness here. In practise, you would probably consider using the UNPACK +-- pragma as well. +-- +-- +-- Now, let's have a look at a decoder for this format. +-- +-- @ +--getTrade :: 'Get' Trade +--getTrade = do +-- timestamp <- 'getWord32le' +-- price <- 'getWord32le' +-- quantity <- 'getWord16le' +-- return '$!' Trade timestamp price quantity +-- @ +-- +-- Or even simpler using applicative style: +-- +-- @ +--getTrade' :: 'Get' Trade +--getTrade' = Trade '<$>' 'getWord32le' '<*>' 'getWord32le' '<*>' 'getWord16le' +-- @ +-- +-- There are two kinds of ways to execute this decoder, the lazy input +-- method and the incremental input method. Here we will use the lazy +-- input method. +-- +-- Let's first define a function that decodes many @Trade@s. +-- +-- @ +--getTrades :: Get [Trade] +--getTrades = do +-- empty <- 'isEmpty' +-- if empty +-- then return [] +-- else do trade <- getTrade +-- trades <- getTrades +-- return (trade:trades) +-- @ +-- +-- Finally, we run the decoder: +-- +-- @ +--lazyIOExample :: IO [Trade] +--lazyIOExample = do +-- input <- BL.readFile \"trades.bin\" +-- return ('runGet' getTrades input) +-- @ +-- +-- This decoder has the downside that it will need to read all the input before +-- it can return. On the other hand, it will not return anything until +-- it knows it could decode without any decoder errors. +-- +-- You could also refactor to a left-fold, to decode in a more streaming fashion, +-- and get the following decoder. It will start to return data without knowing +-- that it can decode all input. +-- +-- @ +--incrementalExample :: BL.ByteString -> [Trade] +--incrementalExample input0 = go decoder input0 +-- where +-- decoder = 'runGetIncremental' getTrade +-- go :: 'Decoder' Trade -> BL.ByteString -> [Trade] +-- go ('Done' leftover _consumed trade) input = +-- trade : go decoder (BL.chunk leftover input) +-- go ('Partial' k) input = +-- go (k . takeHeadChunk $ input) (dropHeadChunk input) +-- go ('Fail' _leftover _consumed msg) _input = +-- error msg +-- +--takeHeadChunk :: BL.ByteString -> Maybe BS.ByteString +--takeHeadChunk lbs = +-- case lbs of +-- (BL.Chunk bs _) -> Just bs +-- _ -> Nothing +-- +--dropHeadChunk :: BL.ByteString -> BL.ByteString +--dropHeadChunk lbs = +-- case lbs of +-- (BL.Chunk _ lbs') -> lbs' +-- _ -> BL.Empty +-- @ +-- +-- The @lazyIOExample@ uses lazy I/O to read the file from the disk, which is +-- not suitable in all applications, and certainly not if you need to read +-- from a socket which has higher likelihood to fail. To address these needs, +-- use the incremental input method like in @incrementalExample@. +-- For an example of how to read incrementally from a Handle, +-- see the implementation of 'decodeFileOrFail' in "Data.Binary". +----------------------------------------------------------------------------- + + +module Data.Binary.Get.Ext ( + + -- * The Get monad + Get + + -- * The lazy input interface + -- $lazyinterface + , runGetOrFail + , ByteOffset + + -- * The incremental input interface + -- $incrementalinterface + , Decoder(..) + , runGetIncremental + + -- ** Providing input + , pushChunk + , pushChunks + , pushEndOfInput + + -- * Decoding + , skip + , isEmpty + , bytesRead + , totalBytesRead + , isolate + , lookAhead + , lookAheadM + , lookAheadE + , label + , onError + , withError + , failG + + -- ** ByteStrings + , getByteString + , getLazyByteString + , getLazyByteStringNul + , getRemainingLazyByteString + + -- ** Decoding Words + , getWord8 + + -- *** Big-endian decoding + , getWord16be + , getWord32be + , getWord64be + + -- *** Little-endian decoding + , getWord16le + , getWord32le + , getWord64le + + -- *** Host-endian, unaligned decoding + , getWordhost + , getWord16host + , getWord32host + , getWord64host + + -- ** Decoding Ints + , getInt8 + + -- *** Big-endian decoding + , getInt16be + , getInt32be + , getInt64be + + -- *** Little-endian decoding + , getInt16le + , getInt32le + , getInt64le + + -- *** Host-endian, unaligned decoding + , getInthost + , getInt16host + , getInt32host + , getInt64host + + -- ** Decoding Floats/Doubles + , getFloatbe + , getFloatle + , getFloathost + , getDoublebe + , getDoublele + , getDoublehost + + ) where +#if ! MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +import Foreign +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Internal as L + +import Data.Binary.Get.Ext.Internal hiding ( Decoder(..), runGetIncremental ) +import qualified Data.Binary.Get.Ext.Internal as I + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +-- needed for (# unboxing #) with magic hash +import GHC.Base +import GHC.Word +#endif + +-- needed for casting words to float/double +import Data.Binary.FloatCast (wordToFloat, wordToDouble) + +-- $lazyinterface +-- The lazy interface consumes a single lazy 'L.ByteString'. It's the easiest +-- interface to get started with, but it doesn't support interleaving I\/O and +-- parsing, unless lazy I/O is used. +-- +-- There is no way to provide more input other than the initial data. To be +-- able to incrementally give more data, see the incremental input interface. + +-- $incrementalinterface +-- The incremental interface gives you more control over how input is +-- provided during parsing. This lets you e.g. interleave parsing and +-- I\/O. +-- +-- The incremental interface consumes a strict 'B.ByteString' at a time, each +-- being part of the total amount of input. If your decoder needs more input to +-- finish it will return a 'Partial' with a continuation. +-- If there is no more input, provide it 'Nothing'. +-- +-- 'Fail' will be returned if it runs into an error, together with a message, +-- the position and the remaining input. +-- If it succeeds it will return 'Done' with the resulting value, +-- the position and the remaining input. + +-- | A decoder procuced by running a 'Get' monad. +data Decoder e a = Fail !B.ByteString {-# UNPACK #-} !ByteOffset (Either String e) + -- ^ The decoder ran into an error. The decoder either used + -- 'fail' or was not provided enough input. Contains any + -- unconsumed input and the number of bytes consumed. + | Partial (Maybe B.ByteString -> Decoder e a) + -- ^ The decoder has consumed the available input and needs + -- more to continue. Provide 'Just' if more input is available + -- and 'Nothing' otherwise, and you will get a new 'Decoder'. + | Done !B.ByteString {-# UNPACK #-} !ByteOffset a + -- ^ The decoder has successfully finished. Except for the + -- output value you also get any unused input as well as the + -- number of bytes consumed. + +-- | Run a 'Get' monad. See 'Decoder' for what to do next, like providing +-- input, handling decoder errors and to get the output value. +-- Hint: Use the helper functions 'pushChunk', 'pushChunks' and +-- 'pushEndOfInput'. +runGetIncremental :: ByteOffset -> Get e a -> Decoder e a +runGetIncremental base_offset = calculateOffset base_offset . I.runGetIncremental base_offset + +calculateOffset :: ByteOffset -> I.Decoder e a -> Decoder e a +calculateOffset base_offset r0 = go r0 0 + where + go r !acc = case r of + I.Done inp a -> Done inp (base_offset + (acc - fromIntegral (B.length inp))) a + I.Fail inp s -> Fail inp (base_offset + (acc - fromIntegral (B.length inp))) s + I.Partial k -> + Partial $ \ms -> + case ms of + Nothing -> go (k Nothing) acc + Just i -> go (k ms) (acc + fromIntegral (B.length i)) + I.BytesRead unused k -> + go (k $! (acc - unused)) acc + +takeHeadChunk :: L.ByteString -> Maybe B.ByteString +takeHeadChunk lbs = + case lbs of + (L.Chunk bs _) -> Just bs + _ -> Nothing + +dropHeadChunk :: L.ByteString -> L.ByteString +dropHeadChunk lbs = + case lbs of + (L.Chunk _ lbs') -> lbs' + _ -> L.Empty + +-- | Run a 'Get' monad and return 'Left' on failure and 'Right' on +-- success. In both cases any unconsumed input and the number of bytes +-- consumed is returned. In the case of failure, a human-readable +-- error message is included as well. +runGetOrFail :: ByteOffset -> Get e a -> L.ByteString + -> Either (L.ByteString, ByteOffset, Either String e) (L.ByteString, ByteOffset, a) +runGetOrFail ge g lbs0 = feedAll (runGetIncremental ge g) lbs0 + where + feedAll (Done bs pos x) lbs = Right (L.chunk bs lbs, pos, x) + feedAll (Partial k) lbs = feedAll (k (takeHeadChunk lbs)) (dropHeadChunk lbs) + feedAll (Fail x pos msg) xs = Left (L.chunk x xs, pos, msg) + +-- | An offset, counted in bytes. +type ByteOffset = Int64 + +-- | Feed a 'Decoder' with more input. If the 'Decoder' is 'Done' or 'Fail' it +-- will add the input to 'B.ByteString' of unconsumed input. +-- +-- @ +-- 'runGetIncremental' myParser \`pushChunk\` myInput1 \`pushChunk\` myInput2 +-- @ +pushChunk :: Decoder e a -> B.ByteString -> Decoder e a +pushChunk r inp = + case r of + Done inp0 p a -> Done (inp0 `B.append` inp) p a + Partial k -> k (Just inp) + Fail inp0 p s -> Fail (inp0 `B.append` inp) p s + + +-- | Feed a 'Decoder' with more input. If the 'Decoder' is 'Done' or 'Fail' it +-- will add the input to 'ByteString' of unconsumed input. +-- +-- @ +-- 'runGetIncremental' myParser \`pushChunks\` myLazyByteString +-- @ +pushChunks :: Decoder e a -> L.ByteString -> Decoder e a +pushChunks r0 = go r0 . L.toChunks + where + go r [] = r + go (Done inp pos a) xs = Done (B.concat (inp:xs)) pos a + go (Fail inp pos s) xs = Fail (B.concat (inp:xs)) pos s + go (Partial k) (x:xs) = go (k (Just x)) xs + +-- | Tell a 'Decoder' that there is no more input. This passes 'Nothing' to a +-- 'Partial' decoder, otherwise returns the decoder unchanged. +pushEndOfInput :: Decoder e a -> Decoder e a +pushEndOfInput r = + case r of + Done _ _ _ -> r + Partial k -> k Nothing + Fail _ _ _ -> r + +-- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available. +skip :: Int -> Get () () +skip n = withInputChunks (fromIntegral n) consumeBytes (const ()) failOnEOF + +-- | An efficient get method for lazy ByteStrings. Fails if fewer than @n@ +-- bytes are left in the input. +getLazyByteString :: Int64 -> Get () L.ByteString +getLazyByteString n0 = withInputChunks n0 consumeBytes L.fromChunks failOnEOF + +consumeBytes :: Consume Int64 +consumeBytes n str + | fromIntegral (B.length str) >= n = Right (B.splitAt (fromIntegral n) str) + | otherwise = Left (n - fromIntegral (B.length str)) + +consumeUntilNul :: Consume () +consumeUntilNul _ str = + case B.break (==0) str of + (want, rest) | B.null rest -> Left () + | otherwise -> Right (want, B.drop 1 rest) + +consumeAll :: Consume () +consumeAll _ _ = Left () + +resumeOnEOF :: [B.ByteString] -> Get e L.ByteString +resumeOnEOF = return . L.fromChunks + +-- | Get a lazy ByteString that is terminated with a NUL byte. +-- The returned string does not contain the NUL byte. Fails +-- if it reaches the end of input without finding a NUL. +getLazyByteStringNul :: Get () L.ByteString +getLazyByteStringNul = withInputChunks () consumeUntilNul L.fromChunks failOnEOF + +-- | Get the remaining bytes as a lazy ByteString. +-- Note that this can be an expensive function to use as it forces reading +-- all input and keeping the string in-memory. +getRemainingLazyByteString :: Get e L.ByteString +getRemainingLazyByteString = withInputChunks () consumeAll L.fromChunks resumeOnEOF + +------------------------------------------------------------------------ +-- Primtives + +-- helper, get a raw Ptr onto a strict ByteString copied out of the +-- underlying lazy byteString. + +getPtr :: Storable a => Int -> Get () a +getPtr n = readNWith n peek +{-# INLINE getPtr #-} + +-- | Read a Word8 from the monad state +getWord8 :: Get () Word8 +getWord8 = readN 1 B.unsafeHead +{-# INLINE[2] getWord8 #-} + +-- | Read an Int8 from the monad state +getInt8 :: Get () Int8 +getInt8 = fromIntegral <$> getWord8 +{-# INLINE getInt8 #-} + + +-- force GHC to inline getWordXX +{-# RULES +"getWord8/readN" getWord8 = readN 1 B.unsafeHead +"getWord16be/readN" getWord16be = readN 2 word16be +"getWord16le/readN" getWord16le = readN 2 word16le +"getWord32be/readN" getWord32be = readN 4 word32be +"getWord32le/readN" getWord32le = readN 4 word32le +"getWord64be/readN" getWord64be = readN 8 word64be +"getWord64le/readN" getWord64le = readN 8 word64le #-} + +-- | Read a Word16 in big endian format +getWord16be :: Get () Word16 +getWord16be = readN 2 word16be + +word16be :: B.ByteString -> Word16 +word16be = \s -> + (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w16` 8) .|. + (fromIntegral (s `B.unsafeIndex` 1)) +{-# INLINE[2] getWord16be #-} +{-# INLINE word16be #-} + +-- | Read a Word16 in little endian format +getWord16le :: Get () Word16 +getWord16le = readN 2 word16le + +word16le :: B.ByteString -> Word16 +word16le = \s -> + (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w16` 8) .|. + (fromIntegral (s `B.unsafeIndex` 0) ) +{-# INLINE[2] getWord16le #-} +{-# INLINE word16le #-} + +-- | Read a Word32 in big endian format +getWord32be :: Get () Word32 +getWord32be = readN 4 word32be + +word32be :: B.ByteString -> Word32 +word32be = \s -> + (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w32` 24) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 16) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 8) .|. + (fromIntegral (s `B.unsafeIndex` 3) ) +{-# INLINE[2] getWord32be #-} +{-# INLINE word32be #-} + +-- | Read a Word32 in little endian format +getWord32le :: Get () Word32 +getWord32le = readN 4 word32le + +word32le :: B.ByteString -> Word32 +word32le = \s -> + (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w32` 24) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w32` 16) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w32` 8) .|. + (fromIntegral (s `B.unsafeIndex` 0) ) +{-# INLINE[2] getWord32le #-} +{-# INLINE word32le #-} + +-- | Read a Word64 in big endian format +getWord64be :: Get () Word64 +getWord64be = readN 8 word64be + +word64be :: B.ByteString -> Word64 +word64be = \s -> + (fromIntegral (s `B.unsafeIndex` 0) `shiftl_w64` 56) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 48) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 40) .|. + (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 32) .|. + (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 24) .|. + (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 16) .|. + (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 8) .|. + (fromIntegral (s `B.unsafeIndex` 7) ) +{-# INLINE[2] getWord64be #-} +{-# INLINE word64be #-} + +-- | Read a Word64 in little endian format +getWord64le :: Get () Word64 +getWord64le = readN 8 word64le + +word64le :: B.ByteString -> Word64 +word64le = \s -> + (fromIntegral (s `B.unsafeIndex` 7) `shiftl_w64` 56) .|. + (fromIntegral (s `B.unsafeIndex` 6) `shiftl_w64` 48) .|. + (fromIntegral (s `B.unsafeIndex` 5) `shiftl_w64` 40) .|. + (fromIntegral (s `B.unsafeIndex` 4) `shiftl_w64` 32) .|. + (fromIntegral (s `B.unsafeIndex` 3) `shiftl_w64` 24) .|. + (fromIntegral (s `B.unsafeIndex` 2) `shiftl_w64` 16) .|. + (fromIntegral (s `B.unsafeIndex` 1) `shiftl_w64` 8) .|. + (fromIntegral (s `B.unsafeIndex` 0) ) +{-# INLINE[2] getWord64le #-} +{-# INLINE word64le #-} + + +-- | Read an Int16 in big endian format. +getInt16be :: Get () Int16 +getInt16be = fromIntegral <$> getWord16be +{-# INLINE getInt16be #-} + +-- | Read an Int32 in big endian format. +getInt32be :: Get () Int32 +getInt32be = fromIntegral <$> getWord32be +{-# INLINE getInt32be #-} + +-- | Read an Int64 in big endian format. +getInt64be :: Get () Int64 +getInt64be = fromIntegral <$> getWord64be +{-# INLINE getInt64be #-} + + +-- | Read an Int16 in little endian format. +getInt16le :: Get () Int16 +getInt16le = fromIntegral <$> getWord16le +{-# INLINE getInt16le #-} + +-- | Read an Int32 in little endian format. +getInt32le :: Get () Int32 +getInt32le = fromIntegral <$> getWord32le +{-# INLINE getInt32le #-} + +-- | Read an Int64 in little endian format. +getInt64le :: Get () Int64 +getInt64le = fromIntegral <$> getWord64le +{-# INLINE getInt64le #-} + + +------------------------------------------------------------------------ +-- Host-endian reads + +-- | /O(1)./ Read a single native machine word. The word is read in +-- host order, host endian form, for the machine you're on. On a 64 bit +-- machine the Word is an 8 byte value, on a 32 bit machine, 4 bytes. +getWordhost :: Get () Word +getWordhost = getPtr (sizeOf (undefined :: Word)) +{-# INLINE getWordhost #-} + +-- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness. +getWord16host :: Get () Word16 +getWord16host = getPtr (sizeOf (undefined :: Word16)) +{-# INLINE getWord16host #-} + +-- | /O(1)./ Read a Word32 in native host order and host endianness. +getWord32host :: Get () Word32 +getWord32host = getPtr (sizeOf (undefined :: Word32)) +{-# INLINE getWord32host #-} + +-- | /O(1)./ Read a Word64 in native host order and host endianess. +getWord64host :: Get () Word64 +getWord64host = getPtr (sizeOf (undefined :: Word64)) +{-# INLINE getWord64host #-} + +-- | /O(1)./ Read a single native machine word in native host +-- order. It works in the same way as 'getWordhost'. +getInthost :: Get () Int +getInthost = getPtr (sizeOf (undefined :: Int)) +{-# INLINE getInthost #-} + +-- | /O(1)./ Read a 2 byte Int16 in native host order and host endianness. +getInt16host :: Get () Int16 +getInt16host = getPtr (sizeOf (undefined :: Int16)) +{-# INLINE getInt16host #-} + +-- | /O(1)./ Read an Int32 in native host order and host endianness. +getInt32host :: Get () Int32 +getInt32host = getPtr (sizeOf (undefined :: Int32)) +{-# INLINE getInt32host #-} + +-- | /O(1)./ Read an Int64 in native host order and host endianess. +getInt64host :: Get () Int64 +getInt64host = getPtr (sizeOf (undefined :: Int64)) +{-# INLINE getInt64host #-} + + +------------------------------------------------------------------------ +-- Double/Float reads + +-- | Read a 'Float' in big endian IEEE-754 format. +getFloatbe :: Get () Float +getFloatbe = wordToFloat <$> getWord32be +{-# INLINE getFloatbe #-} + +-- | Read a 'Float' in little endian IEEE-754 format. +getFloatle :: Get () Float +getFloatle = wordToFloat <$> getWord32le +{-# INLINE getFloatle #-} + +-- | Read a 'Float' in IEEE-754 format and host endian. +getFloathost :: Get () Float +getFloathost = wordToFloat <$> getWord32host +{-# INLINE getFloathost #-} + +-- | Read a 'Double' in big endian IEEE-754 format. +getDoublebe :: Get () Double +getDoublebe = wordToDouble <$> getWord64be +{-# INLINE getDoublebe #-} + +-- | Read a 'Double' in little endian IEEE-754 format. +getDoublele :: Get () Double +getDoublele = wordToDouble <$> getWord64le +{-# INLINE getDoublele #-} + +-- | Read a 'Double' in IEEE-754 format and host endian. +getDoublehost :: Get () Double +getDoublehost = wordToDouble <$> getWord64host +{-# INLINE getDoublehost #-} + +------------------------------------------------------------------------ +-- Unchecked shifts + +shiftl_w16 :: Word16 -> Int -> Word16 +shiftl_w32 :: Word32 -> Int -> Word32 +shiftl_w64 :: Word64 -> Int -> Word64 + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i) +shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i) + +#if WORD_SIZE_IN_BITS < 64 +shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i) + +#else +shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i) +#endif + +#else +shiftl_w16 = shiftL +shiftl_w32 = shiftL +shiftl_w64 = shiftL +#endif diff --git a/src/Data/Binary/Get/Ext/Internal.hs b/src/Data/Binary/Get/Ext/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Get/Ext/Internal.hs @@ -0,0 +1,428 @@ +{-# LANGUAGE CPP, RankNTypes, MagicHash, BangPatterns, TypeFamilies #-} + +-- CPP C style pre-precessing, the #if defined lines +-- RankNTypes forall r. statement +-- MagicHash the (# unboxing #), also needs GHC.primitives + +module Data.Binary.Get.Ext.Internal ( + + -- * The Get e type + Get + , runCont + , Decoder(..) + , runGetIncremental + + , readN + , readNWith + + -- * Parsing + , bytesRead + , totalBytesRead + , isolate + + -- * With input chunks + , withInputChunks + , Consume + , failOnEOF + + , get + , put + , ensureN + + -- * Utility + , isEmpty + , failG + , lookAhead + , lookAheadM + , lookAheadE + , label + , onError + , withError + + -- ** ByteStrings + , getByteString + + ) where + +import Foreign +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B + +import Control.Applicative +import Control.Monad +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif + +import Data.Binary.Internal ( accursedUnutterablePerformIO ) + +-- Kolmodin 20100427: at zurihac we discussed of having partial take a +-- "Maybe ByteString" and implemented it in this way. +-- The reasoning was that you could accidently provide an empty bytestring, +-- and it should not terminate the decoding (empty would mean eof). +-- However, I'd say that it's also a risk that you get stuck in a loop, +-- where you keep providing an empty string. Anyway, no new input should be +-- rare, as the RTS should only wake you up if you actually have some data +-- to read from your fd. + +-- | A decoder produced by running a 'Get' monad. +data Decoder e a = Fail !B.ByteString (Either String e) + -- ^ The decoder ran into an error. The decoder either used + -- 'fail' or was not provided enough input. + | Partial (Maybe B.ByteString -> Decoder e a) + -- ^ The decoder has consumed the available input and needs + -- more to continue. Provide 'Just' if more input is available + -- and 'Nothing' otherwise, and you will get a new 'Decoder'. + | Done !B.ByteString a + -- ^ The decoder has successfully finished. Except for the + -- output value you also get the unused input. + | BytesRead {-# UNPACK #-} !Int64 (Int64 -> Decoder e a) + -- ^ The decoder needs to know the current position in the input. + -- Given the number of bytes remaning in the decoder, the outer + -- decoder runner needs to calculate the position and + -- resume the decoding. + +-- unrolled codensity/state monad +newtype Get e a = C { runCont :: forall r. Int64 -> B.ByteString -> Success e a r -> Decoder e r } + +type Success e a r = B.ByteString -> a -> Decoder e r + +instance Monad (Get e) where + return = pure + (>>=) = bindG +#if MIN_VERSION_base(4,9,0) + fail = Fail.fail + +instance Fail.MonadFail (Get e) where +#endif + fail = failG_ + +bindG :: Get e a -> (a -> Get e b) -> Get e b +bindG (C c) f = C $ \ge i ks -> c ge i (\i' a -> (runCont (f a)) ge i' ks) +{-# INLINE bindG #-} + +failG_ :: String -> Get e a +failG_ str = C $ \_ i _ks -> Fail i $ Left str + +failG :: e -> Get e a +failG err = C $ \_ i _ks -> Fail i $ Right err + +apG :: Get e (a -> b) -> Get e a -> Get e b +apG d e = do + b <- d + a <- e + return (b a) +{-# INLINE [0] apG #-} + +fmapG :: (a -> b) -> Get e a -> Get e b +fmapG f m = C $ \ge i ks -> runCont m ge i (\i' a -> ks i' (f a)) +{-# INLINE fmapG #-} + +instance Applicative (Get e) where + pure = \x -> C $ \_ s ks -> ks s x + {-# INLINE [0] pure #-} + (<*>) = apG + {-# INLINE (<*>) #-} + +instance MonadPlus (Get e) where + mzero = empty + mplus = (<|>) + +instance Functor (Get e) where + fmap = fmapG + +instance Functor (Decoder e) where + fmap f (Done s a) = Done s (f a) + fmap f (Partial k) = Partial (fmap f . k) + fmap _ (Fail s err) = Fail s err + fmap f (BytesRead b k) = BytesRead b (fmap f . k) + +instance (Show e, Show a) => Show (Decoder e a) where + show (Fail _ err) = "Fail: " ++ show err + show (Partial _) = "Partial _" + show (Done _ a) = "Done: " ++ show a + show (BytesRead _ _) = "BytesRead" + +-- | Run a 'Get' monad. See 'Decoder' for what to do next, like providing +-- input, handling decoding errors and to get the output value. +runGetIncremental :: Int64 -> Get e a -> Decoder e a +runGetIncremental ge g = noMeansNo $ + runCont g ge B.empty (\i a -> Done i a) + +-- | Make sure we don't have to pass Nothing to a Partial twice. +-- This way we don't need to pass around an EOF value in the Get e monad, it +-- can safely ask several times if it needs to. +noMeansNo :: Decoder e a -> Decoder e a +noMeansNo r0 = go r0 + where + go r = + case r of + Partial k -> Partial $ \ms -> + case ms of + Just _ -> go (k ms) + Nothing -> neverAgain (k ms) + BytesRead n k -> BytesRead n (go . k) + Done _ _ -> r + Fail _ _ -> r + neverAgain r = + case r of + Partial k -> neverAgain (k Nothing) + BytesRead n k -> BytesRead n (neverAgain . k) + Fail _ _ -> r + Done _ _ -> r + +prompt :: B.ByteString -> Decoder e a -> (B.ByteString -> Decoder e a) -> Decoder e a +prompt inp kf ks = prompt' kf (\inp' -> ks (inp `B.append` inp')) + +prompt' :: Decoder e a -> (B.ByteString -> Decoder e a) -> Decoder e a +prompt' kf ks = + let loop = + Partial $ \sm -> + case sm of + Just s | B.null s -> loop + | otherwise -> ks s + Nothing -> kf + in loop + +getBaseOffset :: Get e Int64 +getBaseOffset = C $ \ge s ks -> ks s ge + +-- | Get e the total number of bytes read to this point. +totalBytesRead :: Get e Int64 +totalBytesRead = do + base_offset <- getBaseOffset + offset <- bytesRead + return $ base_offset + offset + +-- | Get e the total number of bytes read to this point. +bytesRead :: Get e Int64 +bytesRead = C $ \_ inp k -> BytesRead (fromIntegral $ B.length inp) (k inp) + +-- | Isolate a decoder to operate with a fixed number of bytes, and fail if +-- fewer bytes were consumed, or more bytes were attempted to be consumed. +-- If the given decoder fails, 'isolate' will also fail. +-- Offset from 'bytesRead' will be relative to the start of 'isolate', not the +-- absolute of the input. +isolate :: Int -- ^ The number of bytes that must be consumed + -> Get e a -- ^ The decoder to isolate + -> (Int -> e) -- ^ The error if fewer bytes were consumed + -> Get e a +isolate n0 act err + | n0 < 0 = fail "isolate: negative size" + | otherwise = do + ge <- getBaseOffset + offset <- bytesRead + go n0 (runCont act (ge + offset) B.empty Done) + where + go !n (Done left x) + | n == 0 && B.null left = return x + | otherwise = do + pushFront left + let consumed = n0 - n - B.length left + failG $ err consumed + go 0 (Partial resume) = go 0 (resume Nothing) + go n (Partial resume) = do + inp <- C $ \_ inp k -> do + let takeLimited str = + let (inp', out) = B.splitAt n str in + k out (Just inp') + case not (B.null inp) of + True -> takeLimited inp + False -> prompt inp (k B.empty Nothing) takeLimited + case inp of + Nothing -> go n (resume Nothing) + Just str -> go (n - B.length str) (resume (Just str)) + go _ (Fail bs (Right ferr)) = pushFront bs >> failG ferr + go _ (Fail bs (Left ferr)) = pushFront bs >> failG_ ferr + go n (BytesRead r resume) = + go n (resume $! fromIntegral n0 - fromIntegral n - r) + +type Consume s = s -> B.ByteString -> Either s (B.ByteString, B.ByteString) + +withInputChunks :: s -> Consume s -> ([B.ByteString] -> b) -> ([B.ByteString] -> Get e b) -> Get e b +withInputChunks initS consume onSucc onFail = go initS [] + where + go state acc = C $ \ge inp ks -> + case consume state inp of + Left state' -> do + let acc' = inp : acc + prompt' + (runCont (onFail (reverse acc')) ge B.empty ks) + (\str' -> runCont (go state' acc') ge str' ks) + Right (want,rest) -> do + ks rest (onSucc (reverse (want:acc))) + +failOnEOF :: [B.ByteString] -> Get () a +failOnEOF bs = C $ \_ _ _ -> Fail (B.concat bs) $ Right () + +-- | Test whether all input has been consumed, i.e. there are no remaining +-- undecoded bytes. +isEmpty :: Get e Bool +isEmpty = C $ \_ inp ks -> + if B.null inp + then prompt inp (ks inp True) (\inp' -> ks inp' False) + else ks inp False + +instance Alternative (Get e) where + empty = C $ \_ inp _ks -> Fail inp $ Left "Data.Binary.Get(Alternative).empty" + {-# INLINE empty #-} + (<|>) f g = do + (decoder, bs) <- runAndKeepTrack f + case decoder of + Done inp x -> C $ \_ _ ks -> ks inp x + Fail _ _ -> pushBack bs >> g + _ -> error "Binary: impossible" + {-# INLINE (<|>) #-} + some p = (:) <$> p <*> many p + {-# INLINE some #-} + many p = do + v <- (Just <$> p) <|> pure Nothing + case v of + Nothing -> pure [] + Just x -> (:) x <$> many p + {-# INLINE many #-} + +-- | Run a decoder and keep track of all the input it consumes. +-- Once it's finished, return the final decoder (always 'Done' or 'Fail'), +-- and unconsume all the the input the decoder required to run. +-- Any additional chunks which was required to run the decoder +-- will also be returned. +runAndKeepTrack :: Get e a -> Get e (Decoder e a, [B.ByteString]) +runAndKeepTrack g = C $ \ge inp ks -> + let r0 = runCont g ge inp (\inp' a -> Done inp' a) + go !acc r = case r of + Done inp' a -> ks inp (Done inp' a, reverse acc) + Partial k -> Partial $ \minp -> go (maybe acc (:acc) minp) (k minp) + Fail inp' s -> ks inp (Fail inp' s, reverse acc) + BytesRead unused k -> BytesRead unused (go acc . k) + in go [] r0 +{-# INLINE runAndKeepTrack #-} + +pushBack :: [B.ByteString] -> Get e () +pushBack [] = C $ \_ inp ks -> ks inp () +pushBack bs = C $ \_ inp ks -> ks (B.concat (inp : bs)) () +{-# INLINE pushBack #-} + +pushFront :: B.ByteString -> Get e () +pushFront bs = C $ \_ inp ks -> ks (B.append bs inp) () +{-# INLINE pushFront #-} + +-- | Run the given decoder, but without consuming its input. If the given +-- decoder fails, then so will this function. +-- +-- /Since: 0.7.0.0/ +lookAhead :: Get e a -> Get e a +lookAhead g = do + (decoder, bs) <- runAndKeepTrack g + case decoder of + Done _ a -> pushBack bs >> return a + Fail inp s -> C $ \_ _ _ -> Fail inp s + _ -> error "Binary: impossible" + +-- | Run the given decoder, and only consume its input if it returns 'Just'. +-- If 'Nothing' is returned, the input will be unconsumed. +-- If the given decoder fails, then so will this function. +-- +-- /Since: 0.7.0.0/ +lookAheadM :: Get e (Maybe a) -> Get e (Maybe a) +lookAheadM g = do + let g' = maybe (Left ()) Right <$> g + either (const Nothing) Just <$> lookAheadE g' + +-- | Run the given decoder, and only consume its input if it returns 'Right'. +-- If 'Left' is returned, the input will be unconsumed. +-- If the given decoder fails, then so will this function. +lookAheadE :: Get e (Either a b) -> Get e (Either a b) +lookAheadE g = do + (decoder, bs) <- runAndKeepTrack g + case decoder of + Done _ (Left x) -> pushBack bs >> return (Left x) + Done inp (Right x) -> C $ \_ _ ks -> ks inp (Right x) + Fail inp s -> C $ \_ _ _ -> Fail inp s + _ -> error "Binary: impossible" + +--- | Label a decoder. If the decoder fails, the label will be appended on +--- a new line to the error message string. +label :: String -> Get String a -> Get String a +label msg = onError (\x -> x ++ "\n" ++ msg) + +-- | Convert decoder error. If the decoder fails, the given function will be applied +-- to the error message. +onError :: (e -> e') -> Get e a -> Get e' a +onError msg decoder = C $ \ge inp ks -> + let r0 = runCont decoder ge inp (\inp' a -> Done inp' a) + go r = case r of + Done inp' a -> ks inp' a + Partial k -> Partial (go . k) + Fail inp' (Left s) -> Fail inp' $ Left s + Fail inp' (Right s) -> Fail inp' $ Right $ msg s + BytesRead u k -> BytesRead u (go . k) + in go r0 + +-- | Set decoder error. If the decoder fails, the given error will be used +-- as the error message. +withError :: Get () a -> e -> Get e a +withError decoder msg = onError (const msg) decoder + +------------------------------------------------------------------------ +-- ByteStrings +-- + +-- | An efficient get method for strict ByteStrings. Fails if fewer than @n@ +-- bytes are left in the input. If @n <= 0@ then the empty string is returned. +getByteString :: Int -> Get () B.ByteString +getByteString n | n > 0 = readN n (B.unsafeTake n) + | otherwise = return B.empty +{-# INLINE getByteString #-} + +-- | Get e the current chunk. +get :: Get e B.ByteString +get = C $ \_ inp ks -> ks inp inp + +-- | Replace the current chunk. +put :: B.ByteString -> Get e () +put s = C $ \_ _inp ks -> ks s () + +-- | Return at least @n@ bytes, maybe more. If not enough data is available +-- the computation will escape with 'Partial'. +readN :: Int -> (B.ByteString -> a) -> Get () a +readN !n f = ensureN n >> unsafeReadN n f +{-# INLINE [0] readN #-} + +{-# RULES + +"readN/readN merge" forall n m f g. + apG (readN n f) (readN m g) = readN (n+m) (\bs -> f bs $ g (B.unsafeDrop n bs)) #-} + +-- | Ensure that there are at least @n@ bytes available. If not, the +-- computation will escape with 'Partial'. +ensureN :: Int -> Get () () +ensureN !n0 = C $ \ge inp ks -> do + if B.length inp >= n0 + then ks inp () + else runCont (withInputChunks n0 enoughChunks onSucc onFail >>= put) ge inp ks + where -- might look a bit funny, but plays very well with GHC's inliner. + -- GHC won't inline recursive functions, so we make ensureN non-recursive + enoughChunks n str + | B.length str >= n = Right (str,B.empty) + | otherwise = Left (n - B.length str) + -- Sometimes we will produce leftovers lists of the form [B.empty, nonempty] + -- where `nonempty` is a non-empty ByteString. In this case we can avoid a copy + -- by simply dropping the empty prefix. In principle ByteString might want + -- to gain this optimization as well + onSucc = B.concat . dropWhile B.null + onFail bss = C $ \_ _ _ -> Fail (B.concat bss) $ Right () +{-# INLINE ensureN #-} + +unsafeReadN :: Int -> (B.ByteString -> a) -> Get () a +unsafeReadN !n f = C $ \_ inp ks -> do + ks (B.unsafeDrop n inp) $! f inp -- strict return + +-- | @readNWith n f@ where @f@ must be deterministic and not have side effects. +readNWith :: Int -> (Ptr a -> IO a) -> Get () a +readNWith n f = do + -- It should be safe to use accursedUnutterablePerformIO here. + -- The action must be deterministic and not have any external side effects. + -- It depends on the value of the ByteString so the value dependencies look OK. + readN n $ \s -> accursedUnutterablePerformIO $ B.unsafeUseAsCString s (f . castPtr) +{-# INLINE readNWith #-} diff --git a/src/Data/Binary/Internal.hs b/src/Data/Binary/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Binary/Internal.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE CPP #-} + +module Data.Binary.Internal + ( accursedUnutterablePerformIO ) where + +#if MIN_VERSION_bytestring(0,10,6) +import Data.ByteString.Internal( accursedUnutterablePerformIO ) +#else +import Data.ByteString.Internal( inlinePerformIO ) + +{-# INLINE accursedUnutterablePerformIO #-} +-- | You must be truly desperate to come to me for help. +accursedUnutterablePerformIO :: IO a -> a +accursedUnutterablePerformIO = inlinePerformIO +#endif diff --git a/tests/Action.hs b/tests/Action.hs new file mode 100644 --- /dev/null +++ b/tests/Action.hs @@ -0,0 +1,425 @@ +{-# LANGUAGE PatternGuards #-} +module Action where + +import Control.Applicative +import Control.Monad +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Data.Char +import Data.Int +import Data.List (intersperse, nub) + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck + +import Arbitrary () +import qualified Data.Binary.Get.Ext as Binary + +tests :: [Test] +tests = [ testProperty "action" prop_action + , testProperty "label" prop_label + , testProperty "fail" prop_fail ] + +data Action + = Actions [Action] + | GetByteString Int + | GetByteStringL Int + | Skip Int + | Isolate Int [Action] + | Try [Action] [Action] + | Label String [Action] + | LookAhead [Action] + -- | First argument is True if this action returns Just, otherwise False. + | LookAheadM Bool [Action] + -- | First argument is True if this action returns Right, otherwise Left. + | LookAheadE Bool [Action] + | BytesRead + | Fail + deriving (Show, Eq) + +instance Arbitrary Action where + arbitrary = fmap Actions (gen_actions False) + shrink action = + case action of + Actions [a] -> [a] + Actions as -> [ Actions as' | as' <- shrink as ] + BytesRead -> [] + Fail -> [] + GetByteString n -> [ GetByteString n' | n' <- shrink n ] + GetByteStringL n -> [ GetByteStringL n' | n' <- shrink n ] + Skip n -> [ Skip n' | n' <- shrink n ] + Isolate n as -> nub $ Actions as : + [ Isolate n' as' | (n',as') <- shrink (n,as) + , n' >= 0 + , n' <= max_len as' + 1 ] + Label str a -> Actions a : [ Label str a' | a' <- shrink a ] + LookAhead a -> Actions a : [ LookAhead a' | a' <- shrink a ] + LookAheadM b a -> Actions a : [ LookAheadM b a' | a' <- shrink a ] + LookAheadE b a -> Actions a : [ LookAheadE b a' | a' <- shrink a ] + Try [Fail] b -> Actions b : [ Try [Fail] b' | b' <- shrink b ] + Try a b -> + [Actions a | not (willFail' a)] + ++ [ Try a' b' | (a',b') <- shrink (a,b) ] + +willFail :: Int -> [Action] -> Bool +willFail inp xxs = + case eval inp xxs of + EFail {} -> True + _ -> False + +willFail' :: [Action] -> Bool +willFail' = willFail maxBound + +-- | The maximum length of input decoder can request. +-- The decoder may end up using less, but never more. +-- This way, you know how much input to generate for running a decoder test. +max_len :: [Action] -> Int +max_len [] = 0 +max_len (x:xs) = + case x of + Actions xs' -> max_len (xs' ++ xs) + BytesRead -> max_len xs + Fail -> 0 + GetByteString n -> n + max_len xs + GetByteStringL n -> n + max_len xs + Skip n -> n + max_len xs + Isolate n xs' + | Just _ <- actual_len' [Isolate n xs'] -> n + max_len xs + | otherwise -> n + Label _ xs' -> max_len (xs' ++ xs) + LookAhead xs' + | willFail' xs' -> max_len xs' + | otherwise -> max (max_len xs') (max_len xs) + LookAheadM consume xs' + | consume -> max_len (xs' ++ xs) + | otherwise -> max_len (LookAhead xs' : xs) + LookAheadE consume xs' + | consume -> max_len (xs' ++ xs) + | otherwise -> max_len (LookAhead xs' : xs) + Try a b + | willFail' a && willFail' b -> max (max_len a) (max_len b) + | willFail' a -> max (max_len a) (max_len b) + max_len xs + | otherwise -> max_len (a ++ xs) + +-- | The actual length of input that will be consumed when +-- a decoder is executed, or Nothing if the decoder will fail. +actual_len :: Int -> [Action] -> Maybe Int +actual_len inp xs = + case eval inp xs of + ESuccess inp' -> Just (inp - inp') + _ -> Nothing + +actual_len' :: [Action] -> Maybe Int +actual_len' = actual_len maxBound + +randomInput :: Int -> Gen L.ByteString +randomInput 0 = return L.empty +randomInput n = do + m <- choose (1, min n 10) + s <- vectorOf m $ choose ('a', 'z') + let b = B.pack $ map (fromIntegral.ord) s + rest <- randomInput (n-m) + return (L.append (L.fromChunks [b]) rest) + +-- | Build binary programs and compare running them to running a (hopefully) +-- identical model. +-- Tests that 'bytesRead' returns correct values when used together with '<|>' +-- and 'fail'. +prop_action :: Property +prop_action = + forAllShrink (gen_actions False) shrink $ \ actions -> + let max_len_input = max_len actions in + forAll (randomInput max_len_input) $ \ lbs -> + let allInput = B.concat (L.toChunks lbs) in + case Binary.runGetOrFail 0 (execute allInput actions) lbs of + Right (_inp, _off, _x) -> True + Left (_inp, _off, _msg) -> True + +-- | When a decoder aborts with 'fail', check that all relevant uses of 'label' +-- are respected. +prop_label :: Property +prop_label = + forAllShrink (gen_actions True) shrink $ \ actions -> + let max_len_input = max_len actions in + forAll (randomInput max_len_input) $ \ lbs -> + let allInput = B.concat (L.toChunks lbs) in + collect (failReason $ eval max_len_input actions) $ + case Binary.runGetOrFail 0 (execute allInput actions) lbs of + Left (_, _, Left e) -> error $ "Internal error " ++ e + Left (_inp, _off, Right msg) -> + let lbls = case collectLabels max_len_input actions of + Just lbls' -> lbls' + Nothing -> error ("expected labels, got: " ++ msg) + expectedMsg = concat $ intersperse "\n" lbls + in expectedMsg === msg + Right (_inp, _off, _value) -> label "test case without 'fail'" $ True + +-- | When a decoder aborts with 'fail', check the fail position and +-- remaining input. +prop_fail :: Property +prop_fail = + forAllShrink (gen_actions True) shrink $ \ actions -> + let max_len_input = max_len actions in + forAll (randomInput max_len_input) $ \ lbs -> + let allInput = B.concat (L.toChunks lbs) in + collect (failReason $ eval max_len_input actions) $ + case Binary.runGetOrFail 0 (execute allInput actions) lbs of + Left (inp, off, _msg) -> + case () of + _ | Just off /= findFailPosition max_len_input actions -> + error ("fail position incorrect, expected " ++ + show (findFailPosition max_len_input actions) ++ + " but got " ++ show off) + | inp /= L.drop (fromIntegral off) lbs -> + error $ "remaining output incorrect, was: " ++ show inp ++ + ", should hav been: " ++ show (L.drop (fromIntegral off) lbs) + | otherwise -> property True + Right (_inp, _off, _value) -> label "test case without 'fail'" $ property True + +-- | Collect all the labels up to a 'fail', or Nothing if the +-- decoder will not fail. +collectLabels :: Int -> [Action] -> Maybe [String] +collectLabels inp xxs = + case eval inp xxs of + EFail _ lbls _ -> Just lbls + _ -> Nothing + +-- | Finds at which byte offset the decoder will fail, +-- or Nothing if it won't fail. +findFailPosition :: Int -> [Action] -> Maybe Binary.ByteOffset +findFailPosition inp xxs = + case eval inp xxs of + EFail _ _ inp' -> return (fromIntegral (inp-inp')) + _ -> Nothing + +failReason :: Eval -> String +failReason (EFail fr _ _) = show fr +failReason _ = "NoFail" + +-- | The result of an evaluation. +data Eval = ESuccess Int + -- ^ The evalutation completed successfully. Contains the number of + -- remaining bytes of the input. + | EFail FailReason [String] Int + -- ^ The evaluation completed with a failure. Contains the labels up + -- to the failure, and the number of remaining bytes of the input. + deriving (Show,Eq) + +data FailReason + = FRFail + | FRIsolateTooMuch + | FRIsolateTooLittle + | FRTooMuch + deriving (Show,Eq) + +-- | Given the number of input bytes and a list of actions, evaluate the +-- actions and return whether the actions succeeed or fail. +eval :: Int -> [Action] -> Eval +eval inp0 = go inp0 [] + where + step :: Int -> Int -> [String] -> [Action] -> Eval + step inp n lbls xs + | inp - n < 0 = + let msg = "not enough bytes" + in EFail FRTooMuch (msg:lbls) inp + | otherwise = go (inp-n) lbls xs + go :: Int -> [String] -> [Action] -> Eval + go inp _lbls [] = ESuccess inp + go inp lbls (x:xs) = + case x of + Actions xs' -> go inp lbls (xs'++xs) + BytesRead -> go inp lbls xs + Fail -> EFail FRFail ("fail":lbls) inp + GetByteString n -> step inp n lbls xs + GetByteStringL n -> step inp n lbls xs + Skip n -> step inp n lbls xs + Isolate n xs' + | n > inp -> + case go inp lbls xs' of + ESuccess inp' -> + let msg = "isolate: the decoder consumed " ++ show (inp - inp') ++ + " bytes which is less than the expected " ++ (show n) ++ + " bytes" + in EFail FRTooMuch (msg:lbls) inp' + efail -> efail + | otherwise -> + case go n lbls xs' of + EFail fr lbls' inp' -> EFail fr lbls' (inp - n + inp') + ESuccess 0 -> go (inp-n) lbls xs + ESuccess inp' -> + let msg = "isolate: the decoder consumed " ++ show (n - inp') ++ + " bytes which is less than the expected " ++ (show n) ++ + " bytes" + in EFail FRIsolateTooLittle (msg:lbls) (inp - n + inp') + Label str xs' -> + case go inp (str:lbls) xs' of + EFail fr lbls' inp' -> EFail fr lbls' inp' + ESuccess inp' -> go inp' lbls xs + LookAhead xs' + | EFail fr lbls' inp' <- go inp lbls xs' -> EFail fr lbls' inp' + | otherwise -> go inp lbls xs + LookAheadM consume xs' + | consume -> go inp lbls (xs'++xs) + | otherwise -> go inp lbls (LookAhead xs' : xs) + LookAheadE consume xs' + | consume -> go inp lbls (xs'++xs) + | otherwise -> go inp lbls (LookAhead xs' : xs) + Try a b -> + case go inp lbls a of + ESuccess inp' -> go inp' lbls xs + EFail {} -> go inp lbls (b++xs) + +getLazyByteString :: Int64 -> Binary.Get String L.ByteString +getLazyByteString = (`Binary.withError` "not enough bytes") . Binary.getLazyByteString + +skip :: Int -> Binary.Get String () +skip = (`Binary.withError` "not enough bytes") . Binary.skip + +isolate :: Int -> Binary.Get String a -> Binary.Get String a +isolate n decoder = + Binary.isolate n decoder (msg n) + where + msg n0 consumed + = "isolate: the decoder consumed " ++ show consumed ++ " bytes" + ++ " which is less than the expected " ++ show n0 ++ " bytes" + +getByteString :: Int -> Binary.Get String B.ByteString +getByteString = (`Binary.withError` "not enough bytes") . Binary.getByteString + +-- | Execute (run) the model. +-- First argument is all the input that will be used when executing +-- this decoder. It is used in this function to compare the expected +-- value with the actual value from the decoder functions. +-- The second argument is the model - the actions we will execute. +execute :: B.ByteString -> [Action] -> Binary.Get String () +execute inp acts0 = go 0 acts0 >> return () + where + inp_len = B.length inp + go _ [] = return () + go pos (x:xs) = + case x of + Actions a -> go pos (a++xs) + GetByteString n -> do + -- Run the operation in the Get monad... + actual <- getByteString n + let expected = B.take n . B.drop pos $ inp + -- ... and compare that we got what we expected. + when (actual /= expected) $ error $ + "execute(getByteString): actual /= expected at pos " ++ show pos ++ + ", got: " ++ show actual ++ ", expected: " ++ show expected + go (pos+n) xs + GetByteStringL n -> do + -- Run the operation in the Get monad... + actual <- L.toStrict <$> getLazyByteString (fromIntegral n) + let expected = B.take n . B.drop pos $ inp + -- ... and compare that we got what we expected. + when (actual /= expected) $ error $ + "execute(getLazyByteString): actual /= expected at pos " ++ show pos ++ + ", got: " ++ show actual ++ ", expected: " ++ show expected + go (pos+n) xs + Skip n -> do + skip n + go (pos+n) xs + BytesRead -> do + pos' <- Binary.bytesRead + if pos == fromIntegral pos' + then go pos xs + else error $ "execute(bytesRead): expected " ++ + show pos ++ " but got " ++ show pos' + Fail -> Binary.failG "fail" + Isolate n as -> do + let str = B.take n (B.drop pos inp) + _ <- isolate n (execute str as) + when (willFail (inp_len - pos) [Isolate n as]) $ + error "expected isolate to fail" + go (pos + n) xs + Label str as -> do + len <- Binary.label str (leg pos as) + go (pos+len) xs + LookAhead a -> do + _ <- Binary.lookAhead (go pos a) + go pos xs + LookAheadM b a -> do + let f True = Just <$> leg pos a + f False = go pos a >> return Nothing + len <- Binary.lookAheadM (f b) + case len of + Nothing -> go pos xs + Just offset -> go (pos+offset) xs + LookAheadE b a -> do + let f True = Right <$> leg pos a + f False = go pos a >> return (Left ()) + len <- Binary.lookAheadE (f b) + case len of + Left _ -> go pos xs + Right offset -> go (pos+offset) xs + Try a b -> do + offset <- leg pos a <|> leg pos b + go (pos+offset) xs + leg pos t = do + go pos t + case actual_len (inp_len - pos) t of + Nothing -> error "impossible: branch should have failed" + Just offset -> return offset + +gen_actions :: Bool -> Gen [Action] +gen_actions genFail = do + acts <- sized (go False) + return acts + where + go :: Bool -> Int -> Gen [Action] + go _ 0 = return [] + go inTry s = oneof $ [ do n <- choose (0,10) + (:) (GetByteString n) <$> go inTry (s-1) + , do n <- choose (0,10) + (:) (GetByteStringL n) <$> go inTry (s-1) + , do n <- choose (0,10) + (:) (Skip n) <$> go inTry (s-1) + , do (:) BytesRead <$> go inTry (s-1) + , do t1 <- go True (s `div` 2) + t2 <- go inTry (s `div` 2) + (:) (Try t1 t2) <$> go inTry (s `div` 2) + , do t <- go inTry (s`div`2) + (:) (LookAhead t) <$> go inTry (s-1) + , do t <- go inTry (s`div`2) + b <- arbitrary + (:) (LookAheadM b t) <$> go inTry (s-1) + , do t <- go inTry (s`div`2) + b <- arbitrary + (:) (LookAheadE b t) <$> go inTry (s-1) + , do t <- go inTry (s`div`2) + Positive n <- arbitrary :: Gen (Positive Int) + (:) (Label ("some label: " ++ show n) t) <$> go inTry (s-1) + , do t <- resize (s`div`2) (gen_isolate (genFail || inTry)) + (:) t <$> go inTry (s-1) + ] ++ [frequency [(if inTry || genFail then 1 else 0, return [Fail]) + ,(9 , go inTry s)]] + +gen_isolate :: Bool -> Gen Action +gen_isolate genFail = gen_actions genFail >>= go + where + go t0 = do + -- We can isolate the decoder with three different ranges; + -- * give too few bytes -> isolate will fail + -- * give exactly right amount of bytes -> isolate + -- will succeed if the given decoder succeeds + -- * give too many bytes -> isolate will fail + -- Here we generate Isolates that belong to the different + -- buckets. + let t = t0 + tooFewBytes n = do + n' <- choose (0, n) + return (n',t) + requiredBytes n = return (n,t) + tooManyBytes n = do + n' <- choose (n+1, n+10) + return (n+n',t) + let trees + | Just n <- actual_len' t = oneof $ + [ requiredBytes n ] ++ + [ tooFewBytes n | genFail ] ++ + [ tooManyBytes n | genFail ] + | otherwise = return (max_len t, t) + (n,t') <- trees + return (Isolate n t') diff --git a/tests/Arbitrary.hs b/tests/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/tests/Arbitrary.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Arbitrary where + +import Test.QuickCheck + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +#if MIN_VERSION_bytestring(0,10,4) +import qualified Data.ByteString.Short as S +#endif + +instance Arbitrary L.ByteString where + arbitrary = fmap L.fromChunks arbitrary + +instance Arbitrary B.ByteString where + arbitrary = B.pack `fmap` arbitrary + +#if MIN_VERSION_bytestring(0,10,4) +instance Arbitrary S.ShortByteString where + arbitrary = S.toShort `fmap` arbitrary +#endif diff --git a/tests/File.hs b/tests/File.hs new file mode 100644 --- /dev/null +++ b/tests/File.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE CPP #-} +module Main where + +#if ! MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +import System.Directory (getTemporaryDirectory) +import System.FilePath (()) +import Test.HUnit + +import Distribution.Simple.Utils (withTempDirectory) +import Distribution.Verbosity (silent) + +import Data.Binary + +data Foo = Bar !Word32 !Word32 !Word32 deriving (Eq, Show) + +instance Binary Foo where + get = Bar <$> get <*> get <*> get + put (Bar a b c) = put (a,b,c) + +exampleData :: [Foo] +exampleData = make bytes + where + make (a:b:c:xs) = Bar a b c : make xs + make _ = [] + bytes = take (256*1024) (cycle [minBound..maxBound]) + +readWriteTest :: Test +readWriteTest = TestCase $ do + tmpDir <- getTemporaryDirectory + withTempDirectory silent tmpDir "foo-dir" $ \dir -> do + let fn = dir "foo.bin" + encodeFile fn exampleData + content <- decodeFile fn + -- It'd be nice to use lsof to verify that 'fn' isn't still open. + exampleData @=? content + +main :: IO () +main = do + _ <- runTestTT readWriteTest + return () diff --git a/tests/QC.hs b/tests/QC.hs new file mode 100644 --- /dev/null +++ b/tests/QC.hs @@ -0,0 +1,739 @@ +{-# LANGUAGE CPP, ScopedTypeVariables #-} +module Main ( main ) where + +#if MIN_VERSION_base(4,8,0) +#define HAS_NATURAL +#endif + +#if MIN_VERSION_base(4,7,0) +#define HAS_FIXED_CONSTRUCTOR +#endif + +import Control.Applicative +import Control.Exception as C (SomeException, catch, evaluate) +import Control.Monad (unless) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Internal as L +import Data.Int +import Data.Ratio +import System.IO.Unsafe + +#ifdef HAS_NATURAL +import Numeric.Natural +#endif + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck + +import qualified Action (tests) +import Arbitrary () +import Data.Binary hiding (Get, get, getWord8) +import Data.Binary.Get.Ext hiding + ( getLazyByteString, getLazyByteStringNul, getWord8 + , getWord16le, getWord16be, getWord16host + , getWord32le, getWord32be, getWord32host + , getWord64le, getWord64be, getWord64host + , getWordhost, getByteString + , getInt8 + , getInt16be, getInt16le, getInt16host + , getInt32be, getInt32le, getInt32host + , getInt64be, getInt64le, getInt64host + , getInthost + ) +import qualified Data.Binary.Get.Ext as Binary + ( getLazyByteString, getLazyByteStringNul, getWord8 + , getWord16le, getWord16be, getWord16host + , getWord32le, getWord32be, getWord32host + , getWord64le, getWord64be, getWord64host + , getWordhost, getByteString + , getInt8 + , getInt16be, getInt16le, getInt16host + , getInt32be, getInt32le, getInt32host + , getInt64be, getInt64le, getInt64host + , getInthost + ) +import Data.Binary.Put + +------------------------------------------------------------------------ + +roundTrip :: (Eq a, Binary a) => a -> (L.ByteString -> L.ByteString) -> Bool +roundTrip a f = a == + {-# SCC "decode.refragment.encode" #-} decode (f (encode a)) + +runGet :: Get String a -> L.ByteString -> a +runGet decoder inp = + case runGetOrFail 0 decoder inp of + Right (_, _, a) -> a + Left (_, pos, msg) -> error $ "Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ show msg + +withStringError :: Get () a -> Get String a +withStringError = (`withError` "not enough bytes") + +getByteString :: Int -> Get String B.ByteString +getByteString = withStringError . Binary.getByteString + +getWord8 :: Get String Word8 +getWord8 = withStringError Binary.getWord8 + +getWord16be :: Get String Word16 +getWord16be = withStringError Binary.getWord16be + +getWord16le :: Get String Word16 +getWord16le = withStringError Binary.getWord16le + +getWord16host :: Get String Word16 +getWord16host = withStringError Binary.getWord16host + +getWord32be :: Get String Word32 +getWord32be = withStringError Binary.getWord32be + +getWord32le :: Get String Word32 +getWord32le = withStringError Binary.getWord32le + +getWord32host :: Get String Word32 +getWord32host = withStringError Binary.getWord32host + +getWord64be :: Get String Word64 +getWord64be = withStringError Binary.getWord64be + +getWord64le :: Get String Word64 +getWord64le = withStringError Binary.getWord64le + +getWord64host :: Get String Word64 +getWord64host = withStringError Binary.getWord64host + +getWordhost :: Get String Word +getWordhost = withStringError Binary.getWordhost + +getInt8 :: Get String Int8 +getInt8 = withStringError Binary.getInt8 + +getInt16be :: Get String Int16 +getInt16be = withStringError Binary.getInt16be + +getInt16le :: Get String Int16 +getInt16le = withStringError Binary.getInt16le + +getInt16host :: Get String Int16 +getInt16host = withStringError Binary.getInt16host + +getInt32be :: Get String Int32 +getInt32be = withStringError Binary.getInt32be + +getInt32le :: Get String Int32 +getInt32le = withStringError Binary.getInt32le + +getInt32host :: Get String Int32 +getInt32host = withStringError Binary.getInt32host + +getInt64be :: Get String Int64 +getInt64be = withStringError Binary.getInt64be + +getInt64le :: Get String Int64 +getInt64le = withStringError Binary.getInt64le + +getInt64host :: Get String Int64 +getInt64host = withStringError Binary.getInt64host + +getInthost :: Get String Int +getInthost = withStringError Binary.getInthost + +roundTripWith :: Eq a => (a -> Put) -> Get String a -> a -> Property +roundTripWith putter getter x = + forAll positiveList $ \xs -> + x == runGet getter (refragment xs (runPut (putter x))) + +-- make sure that a test fails +mustThrowError :: B a +mustThrowError a = unsafePerformIO $ + C.catch (do _ <- C.evaluate a + return False) + (\(_e :: SomeException) -> return True) + +-- low level ones: +-- +-- Words + +prop_Word8 :: Word8 -> Property +prop_Word8 = roundTripWith putWord8 getWord8 + +prop_Word16be :: Word16 -> Property +prop_Word16be = roundTripWith putWord16be getWord16be + +prop_Word16le :: Word16 -> Property +prop_Word16le = roundTripWith putWord16le getWord16le + +prop_Word16host :: Word16 -> Property +prop_Word16host = roundTripWith putWord16host getWord16host + +prop_Word32be :: Word32 -> Property +prop_Word32be = roundTripWith putWord32be getWord32be + +prop_Word32le :: Word32 -> Property +prop_Word32le = roundTripWith putWord32le getWord32le + +prop_Word32host :: Word32 -> Property +prop_Word32host = roundTripWith putWord32host getWord32host + +prop_Word64be :: Word64 -> Property +prop_Word64be = roundTripWith putWord64be getWord64be + +prop_Word64le :: Word64 -> Property +prop_Word64le = roundTripWith putWord64le getWord64le + +prop_Word64host :: Word64 -> Property +prop_Word64host = roundTripWith putWord64host getWord64host + +prop_Wordhost :: Word -> Property +prop_Wordhost = roundTripWith putWordhost getWordhost + +-- Ints + +prop_Int8 :: Int8 -> Property +prop_Int8 = roundTripWith putInt8 getInt8 + +prop_Int16be :: Int16 -> Property +prop_Int16be = roundTripWith putInt16be getInt16be + +prop_Int16le :: Int16 -> Property +prop_Int16le = roundTripWith putInt16le getInt16le + +prop_Int16host :: Int16 -> Property +prop_Int16host = roundTripWith putInt16host getInt16host + +prop_Int32be :: Int32 -> Property +prop_Int32be = roundTripWith putInt32be getInt32be + +prop_Int32le :: Int32 -> Property +prop_Int32le = roundTripWith putInt32le getInt32le + +prop_Int32host :: Int32 -> Property +prop_Int32host = roundTripWith putInt32host getInt32host + +prop_Int64be :: Int64 -> Property +prop_Int64be = roundTripWith putInt64be getInt64be + +prop_Int64le :: Int64 -> Property +prop_Int64le = roundTripWith putInt64le getInt64le + +prop_Int64host :: Int64 -> Property +prop_Int64host = roundTripWith putInt64host getInt64host + +prop_Inthost :: Int -> Property +prop_Inthost = roundTripWith putInthost getInthost + +{- +-- Floats and Doubles + +prop_Floatbe :: Float -> Property +prop_Floatbe = roundTripWith putFloatbe getFloatbe + +prop_Floatle :: Float -> Property +prop_Floatle = roundTripWith putFloatle getFloatle + +prop_Floathost :: Float -> Property +prop_Floathost = roundTripWith putFloathost getFloathost + +prop_Doublebe :: Double -> Property +prop_Doublebe = roundTripWith putDoublebe getDoublebe + +prop_Doublele :: Double -> Property +prop_Doublele = roundTripWith putDoublele getDoublele + +prop_Doublehost :: Double -> Property +prop_Doublehost = roundTripWith putDoublehost getDoublehost +-} + +-- done, partial and fail + +-- | Test partial results. +-- May or may not use the whole input, check conditions for the different +-- outcomes. +prop_partial :: L.ByteString -> Property +prop_partial lbs = forAll (choose (0, L.length lbs * 2)) $ \skipN -> + let result = pushChunks (runGetIncremental 0 decoder) lbs + decoder = do + s <- getByteString (fromIntegral skipN) + return (L.fromChunks [s]) + in case result of + Partial _ -> L.length lbs < skipN + Done unused _pos value -> + and [ L.length value == skipN + , L.append value (L.fromChunks [unused]) == lbs + ] + Fail _ _ _ -> False + +-- | Fail a decoder and make sure the result is sane. +prop_fail :: L.ByteString -> String -> Property +prop_fail lbs msg = forAll (choose (0, L.length lbs)) $ \pos -> + let result = pushChunks (runGetIncremental 0 decoder) lbs + decoder = do + -- use part of the input... + _ <- getByteString (fromIntegral pos) + -- ... then fail + failG msg + in case result of + Fail unused pos' msg' -> + and [ pos == pos' + , Right msg == msg' + , L.length lbs - pos == fromIntegral (B.length unused) + , L.fromChunks [unused] `L.isSuffixOf` lbs + ] + _ -> False -- wuut? + +-- read negative length +prop_getByteString_negative :: Int -> Property +prop_getByteString_negative n = + n < 1 ==> + runGet (getByteString n) L.empty == B.empty + + +prop_bytesRead :: L.ByteString -> Property +prop_bytesRead lbs = + forAll (makeChunks 0 totalLength) $ \chunkSizes -> + let result = pushChunks (runGetIncremental 0 decoder) lbs + decoder = do + -- Read some data and invoke bytesRead several times. + -- Each time, check that the values are what we expect. + flip mapM_ chunkSizes $ \(total, step) -> do + _ <- getByteString (fromIntegral step) + n <- bytesRead + unless (n == total) $ fail "unexpected position" + bytesRead + in case result of + Done unused pos value -> + and [ value == totalLength + , pos == value + , B.null unused + ] + Partial _ -> False + Fail _ _ _ -> False + where + totalLength = L.length lbs + makeChunks total i + | i == 0 = return [] + | otherwise = do + n <- choose (0,i) + let total' = total + n + rest <- makeChunks total' (i - n) + return ((total',n):rest) + + +-- | We're trying to guarantee that the Decoder will not ask for more input +-- with Partial if it has been given Nothing once. +-- In this test we're making the decoder return 'Partial' to get more +-- input, and to get knownledge of the current position using 'BytesRead'. +-- Both of these operations, when used with the <|> operator, result internally +-- in that the decoder return with Partial and BytesRead multiple times, +-- in which case we need to keep track of if the user has passed Nothing to a +-- Partial in the past. +prop_partialOnlyOnce :: Property +prop_partialOnlyOnce = property $ + let result = runGetIncremental 0 (decoder <|> decoder) + decoder = do + 0 <- bytesRead + _ <- getWord8 -- this will make the decoder return with Partial + return "shouldn't get here" + in case result of + -- we expect Partial followed by Fail + Partial k -> case k Nothing of -- push down a Nothing + Fail _ _ _ -> True + Partial _ -> error $ "partial twice! oh noes!" + Done _ _ _ -> error $ "we're not supposed to be done." + _ -> error $ "not partial, error!" + +-- read too much +prop_readTooMuch :: (Eq a, Binary a) => a -> Bool +prop_readTooMuch x = mustThrowError $ x == a && x /= b + where + -- encode 'a', but try to read 'b' too + (a,b) = decode (encode x) + _types = [a,b] + +-- In binary-0.5 the Get monad looked like +-- +-- > data S = S {-# UNPACK #-} !B.ByteString +-- > L.ByteString +-- > {-# UNPACK #-} !Int64 +-- > +-- > newtype Get a = Get { unGet :: S -> (# a, S #) } +-- +-- with a helper function +-- +-- > mkState :: L.ByteString -> Int64 -> S +-- > mkState l = case l of +-- > L.Empty -> S B.empty L.empty +-- > L.Chunk x xs -> S x xs +-- +-- Note that mkState is strict in its first argument. This goes wrong in this +-- function: +-- +-- > getBytes :: Int -> Get B.ByteString +-- > getBytes n = do +-- > S s ss bytes <- traceNumBytes n $ get +-- > if n <= B.length s +-- > then do let (consume,rest) = B.splitAt n s +-- > put $! S rest ss (bytes + fromIntegral n) +-- > return $! consume +-- > else +-- > case L.splitAt (fromIntegral n) (s `join` ss) of +-- > (consuming, rest) -> +-- > do let now = B.concat . L.toChunks $ consuming +-- > put $ mkState rest (bytes + fromIntegral n) +-- > -- forces the next chunk before this one is returned +-- > if (B.length now < n) +-- > then +-- > fail "too few bytes" +-- > else +-- > return now +-- +-- Consider the else-branch of this function; suppose we ask for n bytes; +-- the call to L.splitAt gives us a lazy bytestring 'consuming' of precisely @n@ +-- bytes (unless we don't have enough data, in which case we fail); but then +-- the strict evaluation of mkState on 'rest' means we look ahead too far. +-- +-- Although this is all done completely differently in binary-0.7 it is +-- important that the same bug does not get introduced in some other way. The +-- test is basically the same test that already exists in this test suite, +-- verifying that +-- +-- > decode . refragment . encode == id +-- +-- However, we use a different 'refragment', one that introduces an exception +-- as the tail of the bytestring after rechunking. If we don't look ahead too +-- far then this should make no difference, but if we do then this will throw +-- an exception (for instance, in binary-0.5, this will throw an exception for +-- certain rechunkings, but not for others). +-- +-- To make sure that the property holds no matter what refragmentation we use, +-- we test exhaustively for a single chunk, and all ways to break the string +-- into 2, 3 and 4 chunks. +prop_lookAheadIndepOfChunking :: (Eq a, Binary a) => a -> Property +prop_lookAheadIndepOfChunking testInput = + forAll (testCuts (L.length (encode testInput))) $ + roundTrip testInput . rechunk + where + testCuts :: forall a. (Num a, Enum a) => a -> Gen [a] + testCuts len = elements $ [ [] ] + ++ [ [i] + | i <- [0 .. len] ] + ++ [ [i, j] + | i <- [0 .. len] + , j <- [0 .. len - i] ] + ++ [ [i, j, k] + | i <- [0 .. len] + , j <- [0 .. len - i] + , k <- [0 .. len - i - j] ] + + -- Rechunk a bytestring, leaving the tail as an exception rather than Empty + rechunk :: forall a. Integral a => [a] -> L.ByteString -> L.ByteString + rechunk cuts = fromChunks . cut cuts . B.concat . L.toChunks + where + cut :: [a] -> B.ByteString -> [B.ByteString] + cut [] bs = [bs] + cut (i:is) bs = let (bs0, bs1) = B.splitAt (fromIntegral i) bs + in bs0 : cut is bs1 + + fromChunks :: [B.ByteString] -> L.ByteString + fromChunks [] = error "Binary should not have to ask for this chunk!" + fromChunks (bs:bss) = L.Chunk bs (fromChunks bss) + +-- String utilities + +getLazyByteString :: Int64 -> Get String L.ByteString +getLazyByteString = (`withError` "not enough bytes") . Binary.getLazyByteString + +getLazyByteStringNul :: Get String L.ByteString +getLazyByteStringNul = Binary.getLazyByteStringNul `withError` "not enough bytes" + +prop_getLazyByteString :: L.ByteString -> Property +prop_getLazyByteString lbs = forAll (choose (0, 2 * L.length lbs)) $ \len -> + let result = pushChunks (runGetIncremental 0 decoder) lbs + decoder = getLazyByteString len + in case result of + Done unused _pos value -> + and [ value == L.take len lbs + , L.fromChunks [unused] == L.drop len lbs + ] + Partial _ -> len > L.length lbs + _ -> False + +prop_getLazyByteStringNul :: Word16 -> [Int] -> Property +prop_getLazyByteStringNul count0 fragments = count >= 0 ==> + forAll (choose (0, count)) $ \pos -> + let lbs = case L.splitAt pos (L.replicate count 65) of + (start,end) -> refragment fragments $ L.concat [start, L.singleton 0, end] + result = pushEndOfInput $ pushChunks (runGetIncremental 0 getLazyByteStringNul) lbs + in case result of + Done unused pos' value -> + and [ value == L.take pos lbs + , pos + 1 == pos' -- 1 for the NUL + , L.fromChunks [unused] == L.drop (pos + 1) lbs + ] + _ -> False + where + count = fromIntegral count0 -- to make the generated numbers a bit smaller + +-- | Same as prop_getLazyByteStringNul, but without any NULL in the string. +prop_getLazyByteStringNul_noNul :: Word16 -> [Int] -> Property +prop_getLazyByteStringNul_noNul count0 fragments = count >= 0 ==> + let lbs = refragment fragments $ L.replicate count 65 + result = pushEndOfInput $ pushChunks (runGetIncremental 0 getLazyByteStringNul) lbs + in case result of + Fail _ _ _ -> True + _ -> False + where + count = fromIntegral count0 -- to make the generated numbers a bit smaller + +prop_getRemainingLazyByteString :: L.ByteString -> Property +prop_getRemainingLazyByteString lbs = property $ + let result = pushEndOfInput $ pushChunks (runGetIncremental 0 getRemainingLazyByteString) lbs + in case result of + Done unused pos value -> + and [ value == lbs + , B.null unused + , fromIntegral pos == L.length lbs + ] + _ -> False + +-- sanity: + +invariant_lbs :: L.ByteString -> Bool +invariant_lbs (L.Empty) = True +invariant_lbs (L.Chunk x xs) = not (B.null x) && invariant_lbs xs + +prop_invariant :: (Binary a) => a -> Bool +prop_invariant = invariant_lbs . encode + +-- refragment a lazy bytestring's chunks +refragment :: [Int] -> L.ByteString -> L.ByteString +refragment [] lbs = lbs +refragment (x:xs) lbs = + let x' = fromIntegral . (+1) . abs $ x + rest = refragment xs (L.drop x' lbs) in + L.append (L.fromChunks [B.concat . L.toChunks . L.take x' $ lbs]) rest + +-- check identity of refragmentation +prop_refragment :: L.ByteString -> [Int] -> Bool +prop_refragment lbs xs = lbs == refragment xs lbs + +-- check that refragmention still hold invariant +prop_refragment_inv :: L.ByteString -> [Int] -> Bool +prop_refragment_inv lbs xs = invariant_lbs $ refragment xs lbs + +main :: IO () +main = defaultMain tests + +------------------------------------------------------------------------ + +genInteger :: Gen Integer +genInteger = do + b <- arbitrary + if b then genIntegerSmall else genIntegerSmall + +genIntegerSmall :: Gen Integer +genIntegerSmall = arbitrary + +genIntegerBig :: Gen Integer +genIntegerBig = do + x <- arbitrarySizedIntegral :: Gen Integer + -- arbitrarySizedIntegral generates numbers smaller than + -- (maxBound :: Word32), so let's make them bigger to better test + -- the Binary instance. + return (x + fromIntegral (maxBound :: Word32)) + +#ifdef HAS_NATURAL +genNatural :: Gen Natural +genNatural = do + b <- arbitrary + if b then genNaturalSmall else genNaturalBig + +genNaturalSmall :: Gen Natural +genNaturalSmall = arbitrarySizedNatural + +genNaturalBig :: Gen Natural +genNaturalBig = do + x <- arbitrarySizedNatural :: Gen Natural + -- arbitrarySizedNatural generates numbers smaller than + -- (maxBound :: Word64), so let's make them bigger to better test + -- the Binary instance. + return (x + fromIntegral (maxBound :: Word64)) +#endif + +------------------------------------------------------------------------ + +#if !MIN_VERSION_base(4,7,0) +instance Show Fingerprint where + show (Fingerprint x1 x2) = show (x1,x2) +#endif + +type T a = a -> Property +type B a = a -> Bool + +p :: (Testable p) => p -> Property +p = property + +test :: (Eq a, Binary a) => a -> Property +test a = forAll positiveList (roundTrip a . refragment) + +test' :: (Show a, Arbitrary a) => String -> (a -> Property) -> ([a] -> Property) -> Test +test' desc prop propList = + testGroup desc [ + testProperty desc prop, + testProperty ("[" ++ desc ++ "]") propList + ] + +testWithGen :: (Show a, Eq a, Binary a) => String -> Gen a -> Test +testWithGen desc gen = + testGroup desc [ + testProperty desc (forAll gen test), + testProperty ("[" ++ desc ++ "]") (forAll (listOf gen) test) + ] + +positiveList :: Gen [Int] +positiveList = fmap (filter (/=0) . map abs) $ arbitrary + +tests :: [Test] +tests = + [ testGroup "Utils" + [ testProperty "refragment id" (p prop_refragment) + , testProperty "refragment invariant" (p prop_refragment_inv) + ] + + , testGroup "Boundaries" + [ testProperty "read to much" (p (prop_readTooMuch :: B Word8)) + , testProperty "read negative length" (p (prop_getByteString_negative :: T Int)) + , -- Arbitrary test input + let testInput :: [Int] ; testInput = [0 .. 10] + in testProperty "look-ahead independent of chunking" (p (prop_lookAheadIndepOfChunking testInput)) + ] + + , testGroup "Partial" + [ testProperty "partial" (p prop_partial) + , testProperty "fail" (p prop_fail) + , testProperty "bytesRead" (p prop_bytesRead) + , testProperty "partial only once" (p prop_partialOnlyOnce) + ] + + , testGroup "Model" + Action.tests + + , testGroup "Primitives" + [ testProperty "Word8" (p prop_Word8) + , testProperty "Word16be" (p prop_Word16be) + , testProperty "Word16le" (p prop_Word16le) + , testProperty "Word16host" (p prop_Word16host) + , testProperty "Word32be" (p prop_Word32be) + , testProperty "Word32le" (p prop_Word32le) + , testProperty "Word32host" (p prop_Word32host) + , testProperty "Word64be" (p prop_Word64be) + , testProperty "Word64le" (p prop_Word64le) + , testProperty "Word64host" (p prop_Word64host) + , testProperty "Wordhost" (p prop_Wordhost) + -- Int + , testProperty "Int8" (p prop_Int8) + , testProperty "Int16be" (p prop_Int16be) + , testProperty "Int16le" (p prop_Int16le) + , testProperty "Int16host" (p prop_Int16host) + , testProperty "Int32be" (p prop_Int32be) + , testProperty "Int32le" (p prop_Int32le) + , testProperty "Int32host" (p prop_Int32host) + , testProperty "Int64be" (p prop_Int64be) + , testProperty "Int64le" (p prop_Int64le) + , testProperty "Int64host" (p prop_Int64host) + , testProperty "Inthost" (p prop_Inthost) +{- + -- Float/Double + , testProperty "Floatbe" (p prop_Floatbe) + , testProperty "Floatle" (p prop_Floatle) + , testProperty "Floathost" (p prop_Floathost) + , testProperty "Doublebe" (p prop_Doublebe) + , testProperty "Doublele" (p prop_Doublele) + , testProperty "Doublehost" (p prop_Doublehost) +-} + ] + + , testGroup "String utils" + [ testProperty "getLazyByteString" prop_getLazyByteString + , testProperty "getLazyByteStringNul" prop_getLazyByteStringNul + , testProperty "getLazyByteStringNul No Null" prop_getLazyByteStringNul_noNul + , testProperty "getRemainingLazyByteString" prop_getRemainingLazyByteString + ] + + , testGroup "Using Binary class, refragmented ByteString" + [ test' "()" (test :: T () ) test + , test' "Bool" (test :: T Bool ) test + , test' "Char" (test :: T Char ) test + , test' "Ordering" (test :: T Ordering ) test + , test' "Ratio Int" (test :: T (Ratio Int)) test + + , test' "Word" (test :: T Word ) test + , test' "Word8" (test :: T Word8 ) test + , test' "Word16" (test :: T Word16) test + , test' "Word32" (test :: T Word32) test + , test' "Word64" (test :: T Word64) test + + , test' "Int" (test :: T Int ) test + , test' "Int8" (test :: T Int8 ) test + , test' "Int16" (test :: T Int16) test + , test' "Int32" (test :: T Int32) test + , test' "Int64" (test :: T Int64) test + + , testWithGen "Integer mixed" genInteger + , testWithGen "Integer small" genIntegerSmall + , testWithGen "Integer big" genIntegerBig + +#ifdef HAS_NATURAL + , testWithGen "Natural mixed" genNatural + , testWithGen "Natural small" genNaturalSmall + , testWithGen "Natural big" genNaturalBig +#endif + + , test' "Float" (test :: T Float ) test + , test' "Double" (test :: T Double) test + + , test' "((), ())" (test :: T ((), ()) ) test + , test' "(Word8, Word32)" (test :: T (Word8, Word32) ) test + , test' "(Int8, Int32)" (test :: T (Int8, Int32) ) test + , test' "(Int32, [Int])" (test :: T (Int32, [Int]) ) test + , test' "Maybe Int8" (test :: T (Maybe Int8) ) test + , test' "Either Int8 Int16" (test :: T (Either Int8 Int16) ) test + + , test' "(Int, ByteString)" + (test :: T (Int, B.ByteString) ) test + , test' "[(Int, ByteString)]" + (test :: T [(Int, B.ByteString)] ) test + + , test' "(Maybe Int64, Bool, [Int])" + (test :: T (Maybe Int64, Bool, [Int])) test + , test' "(Maybe Word8, Bool, [Int], Either Bool Word8)" + (test :: T (Maybe Word8, Bool, [Int], Either Bool Word8)) test + , test' "(Maybe Word16, Bool, [Int], Either Bool Word16, Int)" + (test :: T (Maybe Word16, Bool, [Int], Either Bool Word16, Int)) test + +{- + , test' "(Int,Int,Int,Int,Int,Int)" + (test :: T (Int,Int,Int,Int,Int,Int)) test + , test' "(Int,Int,Int,Int,Int,Int,Int)" + (test :: T (Int,Int,Int,Int,Int,Int,Int)) test + , test' "(Int,Int,Int,Int,Int,Int,Int,Int)" + (test :: T (Int,Int,Int,Int,Int,Int,Int,Int)) test + , test' "(Int,Int,Int,Int,Int,Int,Int,Int,Int)" + (test :: T (Int,Int,Int,Int,Int,Int,Int,Int,Int)) test + , test' "(Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)" + (test :: T (Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)) test +-} + + , test' "B.ByteString" (test :: T B.ByteString) test + , test' "L.ByteString" (test :: T L.ByteString) test + ] + + , testGroup "Invariants" $ map (uncurry testProperty) + [ ("B.ByteString invariant", p (prop_invariant :: B B.ByteString )) + , ("[B.ByteString] invariant", p (prop_invariant :: B [B.ByteString] )) + , ("L.ByteString invariant", p (prop_invariant :: B L.ByteString )) + , ("[L.ByteString] invariant", p (prop_invariant :: B [L.ByteString] )) + ] + ]