diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,7 @@ # binary package # +[![Build Status](https://api.travis-ci.org/kolmodin/binary.png?branch=master)](http://travis-ci.org/kolmodin/binary) + *Efficient, pure binary serialisation using lazy ByteStrings.* The ``binary`` package provides Data.Binary, containing the Binary class, @@ -52,42 +54,22 @@ More information in the haddock documentation. -## Deriving binary instances ## - -It is possible to mechanically derive new instances of Binary for your -types, if they support the Data and Typeable classes. A script is -provided in tools/derive. Here's an example of its use. +## Deriving binary instances using GHC's Generic ## - $ cd binary - $ cd tools/derive +Beginning with GHC 7.2, it is possible to use binary serialization without +writing any instance boilerplate code. - $ ghci -fglasgow-exts BinaryDerive.hs +```haskell +{-# LANGUAGE DeriveGeneric #-} - *BinaryDerive> :l Example.hs +import Data.Binary +import GHC.Generics (Generic) - *Main> deriveM (undefined :: Exp) +data Foo = Foo deriving (Generic) - instance Binary Main.Exp where - put (ExpOr a b) = putWord8 0 >> put a >> put b - put (ExpAnd a b) = putWord8 1 >> put a >> put b - put (ExpEq a b) = putWord8 2 >> put a >> put b - put (ExpNEq a b) = putWord8 3 >> put a >> put b - put (ExpAdd a b) = putWord8 4 >> put a >> put b - put (ExpSub a b) = putWord8 5 >> put a >> put b - put (ExpVar a) = putWord8 6 >> put a - put (ExpInt a) = putWord8 7 >> put a - get = do - tag_ <- getWord8 - case tag_ of - 0 -> get >>= \a -> get >>= \b -> return (ExpOr a b) - 1 -> get >>= \a -> get >>= \b -> return (ExpAnd a b) - 2 -> get >>= \a -> get >>= \b -> return (ExpEq a b) - 3 -> get >>= \a -> get >>= \b -> return (ExpNEq a b) - 4 -> get >>= \a -> get >>= \b -> return (ExpAdd a b) - 5 -> get >>= \a -> get >>= \b -> return (ExpSub a b) - 6 -> get >>= \a -> return (ExpVar a) - 7 -> get >>= \a -> return (ExpInt a) - _ -> fail "no decoding" +-- GHC will automatically fill out the instance +instance Binary Foo +``` ## Contributors ## @@ -106,3 +88,6 @@ * Bryan O'Sullivan * Bas van Dijk * Florian Weimer + +For a full list of contributors, see +[here](https://github.com/kolmodin/binary/graphs/contributors). diff --git a/binary.cabal b/binary.cabal --- a/binary.cabal +++ b/binary.cabal @@ -1,5 +1,5 @@ name: binary -version: 0.7.1.0 +version: 0.7.2.0 license: BSD3 license-file: LICENSE author: Lennart Kolmodin @@ -18,7 +18,7 @@ stability: provisional build-type: Simple cabal-version: >= 1.8 -tested-with: GHC == 7.0.4, GHC == 7.4.1, GHC == 7.6.1 +tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.2 extra-source-files: README.md index.html docs/hcar/binary-Lb.tex tools/derive/*.hs tests/Makefile benchmarks/Makefile @@ -31,9 +31,6 @@ type: git location: git://github.com/kolmodin/binary.git -flag development - default: False - library build-depends: base >= 3.0 && < 5, bytestring >= 0.9, containers, array hs-source-dirs: src @@ -56,78 +53,86 @@ ghc-options: -O2 -Wall -fliberate-case-threshold=1000 +-- Due to circular dependency, we cannot make any of the test-suites or +-- benchmark depend on the binary library. Instead, for each test-suite and +-- benchmark, 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: tests + hs-source-dirs: src tests main-is: QC.hs other-modules: Action Arbitrary build-depends: - array, base >= 3.0 && < 5, bytestring >= 0.9, - containers, random>=1.0.1.0, test-framework, test-framework-quickcheck2 >= 0.3, - QuickCheck>=2.5 + QuickCheck>=2.7 - ghc-options: -Wall -O2 - hs-source-dirs: src + -- build dependencies from using binary source rather than depending on the library + build-depends: array, containers + ghc-options: -Wall -O2 -threaded test-suite read-write-file type: exitcode-stdio-1.0 - hs-source-dirs: tests + hs-source-dirs: src tests main-is: File.hs build-depends: base >= 3.0 && < 5, bytestring >= 0.9, - binary, Cabal, directory, filepath, HUnit + -- build dependencies from using binary source rather than depending on the library + build-depends: array, containers ghc-options: -Wall benchmark bench type: exitcode-stdio-1.0 - hs-source-dirs: benchmarks + hs-source-dirs: src benchmarks main-is: Benchmark.hs other-modules: MemBench build-depends: base >= 3.0 && < 5, - binary, bytestring + -- build dependencies from using binary source rather than depending on the library + build-depends: array, containers c-sources: benchmarks/CBenchmark.c include-dirs: benchmarks ghc-options: -O2 benchmark get type: exitcode-stdio-1.0 - hs-source-dirs: benchmarks + hs-source-dirs: src benchmarks main-is: Get.hs build-depends: attoparsec, base >= 3.0 && < 5, - binary, bytestring, cereal, criterion, deepseq, mtl + -- build dependencies from using binary source rather than depending on the library + build-depends: array, containers ghc-options: -O2 benchmark builder type: exitcode-stdio-1.0 - hs-source-dirs: benchmarks + hs-source-dirs: src benchmarks main-is: Builder.hs build-depends: base >= 3.0 && < 5, - binary, bytestring, criterion, deepseq, mtl + -- build dependencies from using binary source rather than depending on the library + build-depends: array, containers ghc-options: -O2 diff --git a/src/Data/Binary/Builder/Base.hs b/src/Data/Binary/Builder/Base.hs --- a/src/Data/Binary/Builder/Base.hs +++ b/src/Data/Binary/Builder/Base.hs @@ -508,7 +508,5 @@ append (ensureFree a) (ensureFree b) = ensureFree (max a b) "flush/flush" - append flush flush = flush - - #-} + append flush flush = flush #-} #endif diff --git a/src/Data/Binary/Get.hs b/src/Data/Binary/Get.hs --- a/src/Data/Binary/Get.hs +++ b/src/Data/Binary/Get.hs @@ -12,7 +12,7 @@ -- Module : Data.Binary.Get -- Copyright : Lennart Kolmodin -- License : BSD3-style (see LICENSE) --- +-- -- Maintainer : Lennart Kolmodin -- Stability : experimental -- Portability : portable to Hugs and GHC. @@ -33,11 +33,11 @@ -- A corresponding Haskell value looks like this: -- -- @ --- data Trade = Trade --- { timestamp :: !'Word32' --- , price :: !'Word32' --- , qty :: !'Word16' --- } deriving ('Show') +--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 @@ -46,21 +46,21 @@ -- -- -- 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 +--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' +--getTrade' :: 'Get' Trade +--getTrade' = Trade '<$>' 'getWord32le' '<*>' 'getWord32le' '<*>' 'getWord16le' -- @ -- -- The applicative style can sometimes result in faster code, as @binary@ @@ -73,24 +73,23 @@ -- 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) +--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: -- -- @ --- example :: IO () --- example = do +--lazyIOExample :: IO [Trade] +--lazyIOExample = do -- input <- BL.readFile \"trades.bin\" --- let trades = runGet getTrades input --- print trades +-- return ('runGet' getTrades input) -- @ -- -- This decoder has the downside that it will need to read all the input before @@ -98,24 +97,41 @@ -- 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 knowning +-- and get the following decoder. It will start to return data without knowing -- that it can decode all input. -- -- @ --- example2 :: BL.ByteString -> [Trade] --- example2 input --- | BL.null input = [] --- | otherwise = --- let (trade, rest, _) = 'runGetState' getTrade input 0 --- in trade : example2 rest +--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 -- @ -- --- Both these examples use lazy I/O to read the file from the disk, which is +-- 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. --- For an example of this, see the implementation of 'decodeFileOrFail' in --- "Data.Binary". +-- 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". ----------------------------------------------------------------------------- @@ -126,7 +142,7 @@ -- * The lazy input interface -- $lazyinterface - , runGet + , runGet , runGetOrFail , ByteOffset @@ -144,9 +160,11 @@ , skip , isEmpty , bytesRead + , isolate , lookAhead , lookAheadM , lookAheadE + , label -- ** ByteStrings , getByteString @@ -200,7 +218,7 @@ -- 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. @@ -255,7 +273,7 @@ go (k $! (acc - unused)) acc -- | DEPRECATED. Provides compatibility with previous versions of this library. --- Run a 'Get' monad and return a tuple with thee values. +-- Run a 'Get' monad and return a tuple with three values. -- The first value is the result of the decoder. The second and third are the -- unused input, and the number of consumed bytes. {-# DEPRECATED runGetState "Use runGetIncremental instead. This function will be removed." #-} @@ -341,7 +359,7 @@ Done _ _ _ -> r Partial k -> k Nothing Fail _ _ _ -> r - + -- | An efficient get method for lazy ByteStrings. Fails if fewer than @n@ -- bytes are left in the input. getLazyByteString :: Int64 -> Get L.ByteString @@ -381,7 +399,7 @@ Just (want,rest) -> do put rest return [want] - + -- | 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. @@ -419,8 +437,7 @@ "getWord32be/readN" getWord32be = readN 4 word32be "getWord32le/readN" getWord32le = readN 4 word32le "getWord64be/readN" getWord64be = readN 8 word64be -"getWord64le/readN" getWord64le = readN 8 word64le - #-} +"getWord64le/readN" getWord64le = readN 8 word64le #-} -- | Read a Word16 in big endian format getWord16be :: Get Word16 diff --git a/src/Data/Binary/Get/Internal.hs b/src/Data/Binary/Get/Internal.hs --- a/src/Data/Binary/Get/Internal.hs +++ b/src/Data/Binary/Get/Internal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, RankNTypes, MagicHash, BangPatterns #-} +{-# LANGUAGE CPP, RankNTypes, MagicHash, BangPatterns, TypeFamilies #-} -- CPP C style pre-precessing, the #if defined lines -- RankNTypes forall r. statement @@ -18,6 +18,7 @@ -- * Parsing , skip , bytesRead + , isolate , get , put @@ -31,6 +32,7 @@ , lookAhead , lookAheadM , lookAheadE + , label -- ** ByteStrings , getByteString @@ -179,6 +181,41 @@ bytesRead :: Get 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 a -- ^ The decoder to isolate + -> Get a +isolate n0 act + | n0 < 0 = fail "isolate: negative size" + | otherwise = go n0 (runCont act 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 + fail $ "isolate: the decoder consumed " ++ show consumed ++ " bytes" ++ + " which is less than the expected " ++ show n0 ++ " bytes" + 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 err) = pushFront bs >> fail err + go n (BytesRead r resume) = + go n (resume $! fromIntegral n0 - fromIntegral n - r) + -- | Demand more input. If none available, fail. demandInput :: Get () demandInput = C $ \inp ks -> @@ -239,6 +276,10 @@ pushBack bs = C $ \ inp ks -> ks (B.concat (inp : bs)) () {-# INLINE pushBack #-} +pushFront :: B.ByteString -> Get () +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. lookAhead :: Get a -> Get a @@ -269,6 +310,18 @@ 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 a -> Get a +label msg decoder = C $ \inp ks -> + let r0 = runCont decoder inp (\inp' a -> Done inp' a) + go r = case r of + Done inp' a -> ks inp' a + Partial k -> Partial (go . k) + Fail inp' s -> Fail inp' (s ++ "\n" ++ msg) + BytesRead u k -> BytesRead u (go . k) + in go r0 + -- | DEPRECATED. Get the number of bytes of remaining input. -- Note that this is an expensive function to use as in order to calculate how -- much input remains, all input has to be read and kept in-memory. @@ -321,8 +374,7 @@ returnG f = readN 0 (const f) "readN 0/returnG swapback" [1] forall f. - readN 0 f = returnG (f B.empty) - #-} + readN 0 f = returnG (f B.empty) #-} -- | Ensure that there are at least @n@ bytes available. If not, the -- computation will escape with 'Partial'. diff --git a/tests/Action.hs b/tests/Action.hs --- a/tests/Action.hs +++ b/tests/Action.hs @@ -1,22 +1,31 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PatternGuards #-} module Action where -import Control.Applicative -import Control.Monad -import Test.QuickCheck -import Data.Maybe ( fromJust ) +import Control.Applicative +import Control.Monad +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Data.Char +import Data.List (intersperse, nub) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck -import qualified Data.Binary.Get as Binary +import Arbitrary () +import qualified Data.Binary.Get as Binary -import Arbitrary() +tests :: [Test] +tests = [ testProperty "action" prop_action + , testProperty "label" prop_label + , testProperty "fail" prop_fail ] data Action = Actions [Action] | GetByteString 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] @@ -31,32 +40,36 @@ case action of Actions [a] -> [a] Actions as -> [ Actions as' | as' <- shrink as ] - GetByteString n -> [ GetByteString n' | n' <- shrink n, n >= 0 ] BytesRead -> [] Fail -> [] - 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 ] + GetByteString n -> [ GetByteString n' | n' <- shrink n, n >= 0 ] + Isolate 0 as -> [ Isolate 0 as' | as' <- shrink as ] + Isolate 1 as -> [ Isolate 0 as' | as' <- shrink as ] + Isolate n0 as -> nub $ + let ns as' = filter (>=0) $ (n0 - 1) : [ 0 .. max_len as' + 1 ] + in Actions as : [ Isolate n' as' + | as' <- [] : shrink as + , n' <- ns as' ] + Label str a -> Actions a : [ Label str a' | a' <- [] : shrink a, a /= []] + LookAhead a -> Actions a : [ LookAhead a' | a' <- [] : shrink a, a /= []] + LookAheadM b a -> Actions a : [ LookAheadM b a' | a' <- [] : shrink a, a /= []] + LookAheadE b a -> Actions a : [ LookAheadE b a' | a' <- [] : shrink a, a /= []] + Try [Fail] b -> Actions b : [ Try [Fail] b' | b' <- [] : shrink b ] Try a b -> - (if not (willFail a) then [Actions a] else []) - ++ [ Try a' b' | a' <- shrink a, b' <- shrink b ] - ++ [ Try a' b | a' <- shrink a ] - ++ [ Try a b' | b' <- shrink b ] + [Actions a | not (willFail' a)] + ++ [ Try a' b' | a' <- [] : shrink a, b' <- [] : shrink b ] + ++ [ Try a' b | a' <- [] : shrink a ] + ++ [ Try a b' | b' <- [] : shrink b ] -willFail :: [Action] -> Bool -willFail [] = False -willFail (x:xs) = - case x of - Actions x' -> willFail x' || willFail xs - GetByteString _ -> willFail xs - Try a b -> (willFail a && willFail b) || willFail xs - LookAhead a -> willFail a || willFail xs - LookAheadM _ a -> willFail a || willFail xs - LookAheadE _ a -> willFail a || willFail xs - BytesRead -> willFail xs - Fail -> True +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. @@ -64,65 +77,202 @@ max_len [] = 0 max_len (x:xs) = case x of - Actions x' -> max_len x' + max_len xs - GetByteString n -> n + max_len xs + Actions xs' -> max_len (xs' ++ xs) BytesRead -> max_len xs Fail -> 0 - Try a b -> max (max_len a) (max_len b) + max_len xs - LookAhead a -> max (max_len a) (max_len xs) - LookAheadM b a | willFail a -> max_len a - | b -> max_len a + max_len xs - | otherwise -> max (max_len a) (max_len xs) - LookAheadE b a | willFail a -> max_len a - | b -> max_len a + max_len xs - | otherwise -> max (max_len a) (max_len xs) + GetByteString 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 :: [Action] -> Maybe Int -actual_len [] = Just 0 -actual_len (x:xs) = - case x of - Actions x' -> (+) <$> actual_len x' <*> rest - GetByteString n -> (n+) <$> rest - Fail -> Nothing - BytesRead -> rest - LookAhead a | willFail a -> Nothing - | otherwise -> rest - LookAheadM b a | willFail a -> Nothing - | b -> (+) <$> actual_len a <*> rest - | otherwise -> rest - LookAheadE b a | willFail a -> Nothing - | b -> (+) <$> actual_len a <*> rest - | otherwise -> rest - Try a b | not (willFail a) -> (+) <$> actual_len a <*> rest - | not (willFail b) -> (+) <$> actual_len b <*> rest - | otherwise -> Nothing +actual_len :: Int -> [Action] -> Maybe Int +actual_len inp xs = + case eval inp xs of + ESuccess inp' -> Just (inp - inp') + _ -> Nothing - where - rest = actual_len xs +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 shrink $ \ actions -> - forAll arbitrary $ \ lbs -> - L.length lbs >= fromIntegral (max_len actions) ==> - let allInput = B.concat (L.toChunks lbs) in - case Binary.runGet (eval allInput actions) lbs of - () -> True + 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 (execute allInput actions) lbs of + Right (_inp, _off, _x) -> True + Left (_inp, _off, _msg) -> True --- | Evaluate (run) the model. +-- | 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 (execute allInput actions) lbs of + Left (_inp, _off, 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 (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 = "demandInput: 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 + 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) + +-- | 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 evaluate. -eval :: B.ByteString -> [Action] -> Binary.Get () -eval str = go 0 +-- The second argument is the model - the actions we will execute. +execute :: B.ByteString -> [Action] -> Binary.Get () +execute inp acts0 = go 0 acts0 >> return () where + inp_len = B.length inp go _ [] = return () go pos (x:xs) = case x of @@ -130,16 +280,28 @@ GetByteString n -> do -- Run the operation in the Get monad... actual <- Binary.getByteString n - let expected = B.take n . B.drop pos $ str + let expected = B.take n . B.drop pos $ inp -- ... and compare that we got what we expected. - when (actual /= expected) $ error "actual /= expected" + when (actual /= expected) $ error $ + "execute(getByteString): actual /= expected at pos " ++ show pos ++ + ", got: " ++ show actual ++ ", expected: " ++ show expected go (pos+n) xs BytesRead -> do pos' <- Binary.bytesRead - if (pos == fromIntegral pos') + if pos == fromIntegral pos' then go pos xs - else error $ "expected " ++ show pos ++ " but got " ++ show pos' + else error $ "execute(bytesRead): expected " ++ + show pos ++ " but got " ++ show pos' Fail -> fail "fail" + Isolate n as -> do + let str = B.take n (B.drop pos inp) + _ <- Binary.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 @@ -162,12 +324,14 @@ go (pos+offset) xs leg pos t = do go pos t - case actual_len t of + case actual_len (inp_len - pos) t of Nothing -> error "impossible: branch should have failed" Just offset -> return offset -gen_actions :: Gen [Action] -gen_actions = sized (go False) +gen_actions :: Bool -> Gen [Action] +gen_actions genFail = do + acts <- sized (go False) + return acts where go :: Bool -> Int -> Gen [Action] go _ 0 = return [] @@ -185,4 +349,38 @@ , do t <- go inTry (s`div`2) b <- arbitrary (:) (LookAheadE b t) <$> go inTry (s-1) - ] ++ [ return [Fail] | inTry ] + , 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/QC.hs b/tests/QC.hs --- a/tests/QC.hs +++ b/tests/QC.hs @@ -1,46 +1,26 @@ {-# LANGUAGE ScopedTypeVariables #-} -module Main where - -import Data.Binary -import Data.Binary.Put -import Data.Binary.Get - -import Control.Applicative -import Control.Monad (unless) - -import qualified Data.ByteString as B --- import qualified Data.ByteString.Internal 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 qualified Data.Map as Map --- import qualified Data.Set as Set --- import qualified Data.IntMap as IntMap --- import qualified Data.IntSet as IntSet - --- import Data.Array (Array) --- import Data.Array.IArray --- import Data.Array.Unboxed (UArray) - --- import Data.Word -import Data.Int -import Data.Ratio - -import Control.Exception as C (catch,evaluate,SomeException) --- import Control.Monad --- import System.Environment --- import System.IO -import System.IO.Unsafe +module Main ( main ) where -import Test.QuickCheck --- import Text.Printf +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 -import Test.Framework -import Test.Framework.Providers.QuickCheck2 --- import Data.Monoid +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck -import Action (prop_action) -import Arbitrary() +import qualified Action (tests) +import Arbitrary () +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put ------------------------------------------------------------------------ @@ -199,7 +179,94 @@ (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 prop_getLazyByteString :: L.ByteString -> Property @@ -304,6 +371,9 @@ , 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" @@ -314,8 +384,7 @@ ] , testGroup "Model" - [ testProperty "action" Action.prop_action - ] + Action.tests , testGroup "Primitives" [ testProperty "Word16be" (p prop_Word16be) @@ -332,9 +401,9 @@ , testGroup "String utils" [ testProperty "getLazyByteString" prop_getLazyByteString - , testProperty "getLazyByteStringNul" prop_getLazyByteStringNul + , testProperty "getLazyByteStringNul" prop_getLazyByteStringNul , testProperty "getLazyByteStringNul No Null" prop_getLazyByteStringNul_noNul - , testProperty "getRemainingLazyByteString" prop_getRemainingLazyByteString + , testProperty "getRemainingLazyByteString" prop_getRemainingLazyByteString ] , testGroup "Using Binary class, refragmented ByteString" $ map (uncurry testProperty) @@ -401,10 +470,6 @@ p (test :: T (Int,Int,Int,Int,Int,Int,Int,Int,Int))) , ("(Int,Int,Int,Int,Int,Int,Int,Int,Int,Int)", p (test :: T (Int,Int,Int,Int,Int,Int,Int,Int,Int,Int))) - {- - , ("IntSet", p (test :: T IntSet.IntSet )) - , ("IntMap ByteString", p (test :: T (IntMap.IntMap B.ByteString) )) - -} , ("B.ByteString", p (test :: T B.ByteString )) , ("L.ByteString", p (test :: T L.ByteString )) @@ -417,6 +482,3 @@ , ("[L.ByteString] invariant", p (prop_invariant :: B [L.ByteString] )) ] ] - --- GHC only: --- ,("Sequence", p (roundTrip :: Seq.Seq Int64 -> Bool))