diff --git a/.gitignore b/.gitignore deleted file mode 100644 --- a/.gitignore +++ /dev/null @@ -1,14 +0,0 @@ -*.hi -*.o -*.p_hi -*.prof -*.tix -.hpc/ -/benchmarks/bench -/benchmarks/builder -/dist/* -/tests/qc -GNUmakefile -dist-boot -dist-install -ghc.mk diff --git a/.hgignore b/.hgignore deleted file mode 100644 --- a/.hgignore +++ /dev/null @@ -1,5 +0,0 @@ -^dist$ -syntax: glob -.*.swp -*~ -\#* diff --git a/README b/README --- a/README +++ b/README @@ -74,4 +74,5 @@ Tomasz Zielonka Stefan Karrmann Bryan O'Sullivan + Bas van Dijk Florian Weimer diff --git a/TODO b/TODO deleted file mode 100644 --- a/TODO +++ /dev/null @@ -1,28 +0,0 @@ -layer handling: - - bit packing - state parameters - string pools - - reading structures from the end of a stream, seek/tell behaviour - -seek based protocols are too hard. - hGetContents/ interleaving. - -user requests: - - get remaining bytestring after a runGet - - some kind of lookahead, or restoring parsing state, or something with - equal functionality. make it another layer on top? - - getLazyByteString takes an Int, which in Haskell98 is only guarantied to - be 29 bits, ie. 512 mb. - maybe we should have a readN64 for allowing reading of larger stuff? - (which could be implemented with readN on 64bit machines) - reference: bringerts tar archive decoder would be limitid to 0.5GB - files, alt. 2GB in GHC - -SYB-deriving - -investigate the UArray instance, it does not seem to compile in GHC 6.4 diff --git a/benchmarks/Get.hs b/benchmarks/Get.hs --- a/benchmarks/Get.hs +++ b/benchmarks/Get.hs @@ -4,7 +4,7 @@ #include "MachDeps.h" #endif -module Main (main) where +module Main where import Control.DeepSeq import Control.Exception (evaluate) @@ -22,6 +22,12 @@ import Data.Binary.Get import Data.Binary ( get ) +import qualified Data.Serialize.Get as Cereal +import qualified Data.Serialize as Cereal + +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.ByteString.Lazy as AL + #if !MIN_VERSION_bytestring(0,10,0) instance NFData S.ByteString instance NFData L.ByteString where @@ -32,21 +38,35 @@ main = do evaluate $ rnf [ rnf brackets, + rnf bracketsInChunks, + rnf bracketCount, rnf oneMegabyte, rnf oneMegabyteLBS ] defaultMain [ - bench "brackets 100k one chunk input" $ - whnf (runTest bracketParser) brackets - , bench "brackets 100k in 1024 100 byte chunks" $ - whnf (runTest bracketParser) bracketsInChunks - , bench "getStruct4 1MB struct of 4 word32 strict" $ - whnf (runTest (getStruct4Strict mega)) oneMegabyteLBS - , bench "getStruct4 1MB struct of 4 word32" $ + bench "brackets 100kb one chunk input" $ + whnf (checkBracket . runTest bracketParser) brackets + , bench "brackets 100kb in 100 byte chunks" $ + whnf (checkBracket . runTest bracketParser) bracketsInChunks + , bench "Attoparsec lazy-bs brackets 100kb one chunk" $ + whnf (checkBracket . runAttoL bracketParser_atto) brackets + , bench "Attoparsec lazy-bs brackets 100kb in 100 byte chunks" $ + whnf (checkBracket . runAttoL bracketParser_atto) bracketsInChunks + , bench "Attoparsec strict-bs brackets 10M0kb one chunk" $ + whnf (checkBracket . runAtto bracketParser_atto) $ S.concat (L.toChunks brackets) + , bench "Binary getStruct4 1MB struct of 4 word8" $ whnf (runTest (getStruct4 mega)) oneMegabyteLBS - , bench "getWord8 1MB chunk size 1 byte" $ + , bench "Cereal getStruct4 1MB struct of 4 word8" $ + whnf (runCereal (getStruct4_cereal mega)) oneMegabyte + , bench "Attoparsec getStruct4 1MB struct of 4 word8" $ + whnf (runAtto (getStruct4_atto mega)) oneMegabyte + , bench "Binary getWord8 1MB chunk size 1 byte" $ whnf (runTest (getWord8N1 mega)) oneMegabyteLBS + , bench "Cereal getWord8 1MB chunk size 1 byte" $ + whnf (runCereal (getWord8N1_cereal mega)) oneMegabyte + , bench "Attoparsec getWord8 1MB chunk size 1 byte" $ + whnf (runAtto (getWord8N1_atto mega)) oneMegabyte , bench "getWord8 1MB chunk size 2 bytes" $ whnf (runTest (getWord8N2 mega)) oneMegabyteLBS , bench "getWord8 1MB chunk size 4 bytes" $ @@ -65,8 +85,18 @@ whnf (runTest (getWord8N16A mega)) oneMegabyteLBS ] -runTest parser inp = runGet parser inp +checkBracket x | x == bracketCount = x + | otherwise = error "argh!" +runTest decoder inp = runGet decoder inp +runCereal decoder inp = Cereal.runGet decoder inp +runAtto decoder inp = case A.parseOnly decoder inp of + Right a -> a + Left err -> error err +runAttoL decoder inp = case AL.parse decoder inp of + AL.Done _ r -> r + a -> error (show a) + -- Defs. oneMegabyte :: S.ByteString @@ -80,49 +110,69 @@ -- 100k of brackets bracketTest inp = runTest bracketParser inp -brackets = L.fromChunks [C8.concat (replicate 1024 "((()((()()))((()(()()()()()()()(((()()()()(()()(()(()())))))()((())())))()())(((())())(()))))()(()))")] -bracketsInChunks = L.fromChunks (replicate 1024 "((()((()()))((()(()()()()()()()(((()()()()(()()(()(()())))))()((())())))()())(((())())(()))))()(()))") +bracketCount :: Int +bracketCount = fromIntegral $ L.length brackets `div` 2 -bracketParser = cont <|> end +brackets = L.fromChunks [C8.concat (L.toChunks bracketsInChunks)] +bracketsInChunks = L.fromChunks (replicate chunksOfBrackets oneChunk) where - end = return 0 + oneChunk = "((()((()()))((()(()()()()()()()(((()()()()(()()(()(()())))))()((())())))()())(((())())(()))))()(()))" + chunksOfBrackets = 102400 `div` S.length oneChunk + +bracketParser :: Get Int +bracketParser = cont <|> return 0 + where cont = do v <- some ( do 40 <- getWord8 - n <- bracketParser + n <- many cont 41 <- getWord8 - return $! n + 1) + return $! sum n + 1) return $! sum v --- Struct strict - -data Struct4S = Struct4S !Word32 !Word32 !Word32 !Word32 +bracketParser_atto :: A.Parser Int +bracketParser_atto = cont <|> return 0 + where + cont = do v <- some ( do A.word8 40 + n <- bracketParser_atto + A.word8 41 + return $! n + 1) + return $! sum v -instance NFData Struct4S where - rnf (Struct4S !a !b !c !d) = () +-- Strict struct of 4 Word8s +data Struct4 = Struct4 {-# UNPACK #-} !Word8 + {-# UNPACK #-} !Word8 + {-# UNPACK #-} !Word8 + {-# UNPACK #-} !Word8 + deriving Show -getStruct4Strict = loop [] +getStruct4 = loop [] where loop acc 0 = return acc loop acc n = do - !w0 <- get - !w1 <- get - !w2 <- get - !w3 <- get - loop (Struct4S w0 w1 w2 w3 : acc) (n - 16) - --- Struct lazy - -data Struct4 = Struct4 Word32 Word32 Word32 Word32 + !w0 <- getWord8 + !w1 <- getWord8 + !w2 <- getWord8 + !w3 <- getWord8 + let !s = Struct4 w0 w1 w2 w3 + loop (s : acc) (n - 4) -instance NFData Struct4 where - rnf (Struct4 !a !b !c !d) = () +getStruct4_cereal = loop [] + where loop acc 0 = return acc + loop acc n = do + !w0 <- Cereal.getWord8 + !w1 <- Cereal.getWord8 + !w2 <- Cereal.getWord8 + !w3 <- Cereal.getWord8 + let !s = Struct4 w0 w1 w2 w3 + loop (s : acc) (n - 4) -getStruct4 = loop [] +getStruct4_atto = loop [] where loop acc 0 = return acc loop acc n = do - w0 <- get - w1 <- get - w2 <- get - w3 <- get - loop (Struct4 w0 w1 w2 w3 : acc) (n - 16) + !w0 <- A.anyWord8 + !w1 <- A.anyWord8 + !w2 <- A.anyWord8 + !w3 <- A.anyWord8 + let !s = Struct4 w0 w1 w2 w3 + loop (s : acc) (n - 4) -- No-allocation loops. @@ -131,15 +181,29 @@ loop s 0 = return s loop s n = do s0 <- getWord8 - loop (s+s0) (n-1) + loop (s0+s) (n-1) +getWord8N1_cereal = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- Cereal.getWord8 + loop (s0+s) (n-1) + +getWord8N1_atto = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- A.anyWord8 + loop (s0+s) (n-1) + getWord8N2 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord8 s1 <- getWord8 - loop (s+s0+s1) (n-2) + loop (s0+s1+s) (n-2) getWord8N2A = loop 0 where loop s n | s `seq` n `seq` False = undefined diff --git a/benchmarks/Makefile b/benchmarks/Makefile --- a/benchmarks/Makefile +++ b/benchmarks/Makefile @@ -2,7 +2,7 @@ ghc-flags := programs := builder bench -SYSTEM_BINARY := binary-0.5.1.0 +SYSTEM_BINARY := binary-0.5.1.1 .PHONY: all all: $(programs) diff --git a/binary.cabal b/binary.cabal --- a/binary.cabal +++ b/binary.cabal @@ -1,13 +1,15 @@ name: binary -version: 0.6.4.0 +version: 0.7.0.0 license: BSD3 license-file: LICENSE author: Lennart Kolmodin -maintainer: Lennart Kolmodin, Don Stewart +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. @@ -17,8 +19,14 @@ build-type: Simple cabal-version: >= 1.8 tested-with: GHC == 7.0.4, GHC == 7.4.1, GHC == 7.6.1 -extra-source-files: README index.html +extra-source-files: + README index.html docs/hcar/binary-Lb.tex + tools/derive/*.hs tests/Makefile benchmarks/Makefile +-- from the benchmark 'bench' +extra-source-files: + benchmarks/CBenchmark.h + source-repository head type: git location: git://github.com/kolmodin/binary.git @@ -52,6 +60,9 @@ type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: QC.hs + other-modules: + Action + Arbitrary build-depends: array, base >= 3.0 && < 5, @@ -62,13 +73,29 @@ test-framework-quickcheck2, QuickCheck>=2.5 - ghc-options: -Wall + ghc-options: -Wall -O2 hs-source-dirs: src +test-suite read-write-file + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: File.hs + build-depends: + base >= 3.0 && < 5, + bytestring >= 0.9, + binary, + Cabal, + directory, + filepath, + HUnit + + ghc-options: -Wall + benchmark bench type: exitcode-stdio-1.0 hs-source-dirs: benchmarks main-is: Benchmark.hs + other-modules: MemBench build-depends: base >= 3.0 && < 5, binary, @@ -82,9 +109,11 @@ hs-source-dirs: benchmarks main-is: Get.hs build-depends: + attoparsec, base >= 3.0 && < 5, binary, bytestring, + cereal, criterion, deepseq, mtl diff --git a/src/Data/Binary.hs b/src/Data/Binary.hs --- a/src/Data/Binary.hs +++ b/src/Data/Binary.hs @@ -10,7 +10,7 @@ -- -- Maintainer : Lennart Kolmodin -- Stability : unstable --- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances +-- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances. -- -- Binary serialisation of Haskell values to and from lazy 'ByteString's. -- The Binary library provides methods for encoding Haskell values as @@ -18,16 +18,23 @@ -- then be written to disk, sent over the network, or further processed -- (for example, compressed with gzip). -- --- The @Binary@ package is notable in that it provides both pure, and +-- The @binary@ package is notable in that it provides both pure, and -- high performance serialisation. -- --- Values are always encoded in network order (big endian) form, and --- encoded data should be portable across machine endianness, word size, --- or compiler version. For example, data encoded using the 'Binary' class --- could be written from GHC, and read back in Hugs. +-- Values encoded using the 'Binary' class are always encoded in network order +-- (big endian) form, and encoded data should be portable across +-- machine endianness, word size, or compiler version. For example, +-- data encoded using the 'Binary' class could be written on any machine, +-- and read back on any another. -- --- You can either provide a hand written implementation of the 'Binary' class, --- or derive one using the generic support. See 'GBinary'. +-- If the specifics of the data format is not important to you, for example, +-- you are more interested in serializing and deserializing values than +-- in which format will be used, it is possible to derive 'Binary' +-- instances using the generic support. See 'GBinary'. +-- +-- If you have specific requirements about the encoding format, you can use +-- the encoding and decoding primitives directly, see the modules +-- "Data.Binary.Get" and "Data.Binary.Put". -- ----------------------------------------------------------------------------- @@ -55,14 +62,12 @@ -- * Binary serialisation , encode -- :: Binary a => a -> ByteString , decode -- :: Binary a => ByteString -> a + , decodeOrFail -- * IO functions for serialisation , encodeFile -- :: Binary a => FilePath -> a -> IO () , decodeFile -- :: Binary a => FilePath -> IO a - --- Lazy put and get --- , lazyPut --- , lazyGet + , decodeFileOrFail , module Data.Word -- useful @@ -77,8 +82,11 @@ import Data.Binary.Generic () #endif +import qualified Data.ByteString as B ( hGet, length ) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Internal as L ( defaultChunkSize ) +import System.IO ( withBinaryFile, IOMode(ReadMode) ) ------------------------------------------------------------------------ @@ -95,12 +103,12 @@ -- structure to serialise: -- -- > instance Binary Exp where --- > put (IntE i) = do put (0 :: Word8) --- > put i --- > put (OpE s e1 e2) = do put (1 :: Word8) --- > put s --- > put e1 --- > put e2 +-- > put (IntE i) = do put (0 :: Word8) +-- > put i +-- > put (OpE s e1 e2) = do put (1 :: Word8) +-- > put s +-- > put e1 +-- > put e2 -- > -- > get = do t <- get :: Get Word8 -- > case t of @@ -165,14 +173,23 @@ {-# INLINE encode #-} -- | Decode a value from a lazy ByteString, reconstructing the original structure. --- decode :: Binary a => ByteString -> a decode = runGet get +-- | Decode a value from a lazy ByteString. Returning 'Left' on failure and +-- 'Right' on success. In both cases the unconsumed input and the number of +-- consumed bytes is returned. In case of failure, a human-readable error +-- message will be returned as well. +decodeOrFail :: Binary a => L.ByteString + -> Either (L.ByteString, ByteOffset, String) + (L.ByteString, ByteOffset, a) +decodeOrFail = runGetOrFail get + + ------------------------------------------------------------------------ -- Convenience IO operations --- | Lazily serialise a value to a file +-- | Lazily serialise a value to a file. -- -- This is just a convenience function, it's defined simply as: -- @@ -185,40 +202,32 @@ encodeFile :: Binary a => FilePath -> a -> IO () encodeFile f v = L.writeFile f (encode v) --- | Lazily reconstruct a value previously written to a file. --- --- This is just a convenience function, it's defined simply as: --- --- > decodeFile f = return . decode =<< B.readFile f --- --- So for example if you wanted to decompress as well, you could use: --- --- > return . decode . decompress =<< B.readFile f --- --- After contructing the data from the input file, 'decodeFile' checks --- if the file is empty, and in doing so will force the associated file --- handle closed, if it is indeed empty. If the file is not empty, --- it is up to the decoding instance to consume the rest of the data, --- or otherwise finalise the resource. --- +-- | Decode a value from a file. In case of errors, 'error' will +-- be called with the error message. decodeFile :: Binary a => FilePath -> IO a decodeFile f = do - s <- L.readFile f - return $ runGet (do v <- get - m <- isEmpty - m `seq` return v) s + result <- decodeFileOrFail f + case result of + Right x -> return x + Left (_,str) -> error str --- needs bytestring 0.9.1.x to work +-- | Decode a value from a file. In case of success, the value will be returned +-- in 'Right'. In case of decoder errors, the error message together with +-- the byte offset will be returned. +decodeFileOrFail :: Binary a => FilePath -> IO (Either (ByteOffset, String) a) +decodeFileOrFail f = + withBinaryFile f ReadMode $ \h -> do + feed (runGetIncremental get) h + where -- TODO: put in Data.Binary.Get and name pushFromHandle? + feed (Done _ _ x) _ = return (Right x) + feed (Fail _ pos str) _ = return (Left (pos, str)) + feed (Partial k) h = do + chunk <- B.hGet h L.defaultChunkSize + case B.length chunk of + 0 -> feed (k Nothing) h + _ -> feed (k (Just chunk)) h ------------------------------------------------------------------------ --- Lazy put and get - --- lazyPut :: (Binary a) => a -> Put --- lazyPut a = put (encode a) - --- lazyGet :: (Binary a) => Get a --- lazyGet = fmap decode get - -- $generics -- -- Beginning with GHC 7.2, it is possible to use binary serialization diff --git a/src/Data/Binary/Class.hs b/src/Data/Binary/Class.hs --- a/src/Data/Binary/Class.hs +++ b/src/Data/Binary/Class.hs @@ -460,11 +460,11 @@ ------------------------------------------------------------------------ -- Maps and Sets -instance (Ord a, Binary a) => Binary (Set.Set a) where +instance (Binary a) => Binary (Set.Set a) where put s = put (Set.size s) >> mapM_ put (Set.toAscList s) get = liftM Set.fromDistinctAscList get -instance (Ord k, Binary k, Binary e) => Binary (Map.Map k e) where +instance (Binary k, Binary e) => Binary (Map.Map k e) where put m = put (Map.size m) >> mapM_ put (Map.toAscList m) get = liftM Map.fromDistinctAscList get 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 @@ -17,15 +17,111 @@ -- Stability : experimental -- Portability : portable to Hugs and GHC. -- --- The Get monad. A monad for efficiently building structures from +-- 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' +-- @ +-- +-- The applicative style can sometimes result in faster code, as @binary@ +-- will try to optimize the code by grouping the reads together. +-- +-- 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: +-- +-- @ +-- example :: IO () +-- example = do +-- input <- BL.readFile \"trades.bin\" +-- let trades = runGet getTrades input +-- print trades +-- @ +-- +-- 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 knowning +-- 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 +-- @ +-- +-- Both these examples use 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". ----------------------------------------------------------------------------- module Data.Binary.Get ( - -- * The Get type + -- * The Get monad Get -- * The lazy input interface @@ -44,11 +140,12 @@ , pushChunks , pushEndOfInput - -- * Parsing + -- * Decoding , skip , isEmpty , bytesRead - -- , lookAhead + , lookAhead + , lookAheadM -- ** ByteStrings , getByteString @@ -85,6 +182,7 @@ 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 Control.Applicative @@ -161,27 +259,36 @@ -- unused input, and the number of consumed bytes. {-# DEPRECATED runGetState "Use runGetPartial instead. This function will be removed." #-} runGetState :: Get a -> L.ByteString -> ByteOffset -> (a, L.ByteString, ByteOffset) -runGetState g lbs0 pos' = go (runGetIncremental g) (L.toChunks lbs0) +runGetState g lbs0 pos' = go (runGetIncremental g) lbs0 where - go (Done s pos a) lbs = (a, L.fromChunks (s:lbs), pos+pos') - go (Partial k) (x:xs) = go (k $ Just x) xs - go (Partial k) [] = go (k Nothing) [] + go (Done s pos a) lbs = (a, L.chunk s lbs, pos+pos') + go (Partial k) lbs = go (k (takeHeadChunk lbs)) (dropHeadChunk lbs) go (Fail _ pos msg) _ = error ("Data.Binary.Get.runGetState at position " ++ show pos ++ ": " ++ msg) +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 :: Get a -> L.ByteString -> Either (L.ByteString, ByteOffset, String) (L.ByteString, ByteOffset, a) -runGetOrFail g bs = feedAll (runGetIncremental g) chunks +runGetOrFail g lbs0 = feedAll (runGetIncremental g) lbs0 where - chunks = L.toChunks bs - feedAll (Done x pos r) xs = Right ((L.fromChunks (x:xs)), pos, r) - feedAll (Partial k) (x:xs) = feedAll (k (Just x)) xs - feedAll (Partial k) [] = feedAll (k Nothing) [] - feedAll (Fail x pos msg) xs = Left ((L.fromChunks (x:xs)), pos, msg) + 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 @@ -189,12 +296,10 @@ -- | The simplest interface to run a 'Get' decoder. If the decoder runs into -- an error, calls 'fail', or runs out of input, it will call 'error'. runGet :: Get a -> L.ByteString -> a -runGet g bs = feedAll (runGetIncremental g) chunks +runGet g lbs0 = feedAll (runGetIncremental g) lbs0 where - chunks = L.toChunks bs - feedAll (Done _ _ r) _ = r - feedAll (Partial k) (x:xs) = feedAll (k (Just x)) xs - feedAll (Partial k) [] = feedAll (k Nothing) [] + feedAll (Done _ _ x) _ = x + feedAll (Partial k) lbs = feedAll (k (takeHeadChunk lbs)) (dropHeadChunk lbs) feedAll (Fail _ pos msg) _ = error ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg) @@ -213,7 +318,8 @@ 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. +-- | Feed a 'Decoder' with more input. If the 'Decoder' is 'Done' or 'Fail' it +-- will add the input to 'ByteString' of unconsumed input. -- -- @ -- 'runGetPartial' myParser \`pushChunks\` myLazyByteString @@ -222,7 +328,9 @@ pushChunks r0 = go r0 . L.toChunks where go r [] = r - go r (x:xs) = go (pushChunk r x) xs + 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. 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 @@ -28,6 +28,8 @@ , remaining , getBytes , isEmpty + , lookAhead + , lookAheadM -- ** ByteStrings , getByteString @@ -77,7 +79,7 @@ newtype Get a = C { runCont :: forall r. B.ByteString -> Success a r -> - Decoder r } + Decoder r } type Success a r = B.ByteString -> a -> Decoder r @@ -197,14 +199,12 @@ instance Alternative Get where empty = C $ \inp _ks -> Fail inp "Data.Binary.Get(Alternative).empty" - (<|>) f g = C $ \inp ks -> - let r0 = runCont (try f) inp (\inp' a -> Done inp' a) - go r = case r of - Done inp' a -> ks inp' a - Partial k -> Partial (go . k) - Fail inp' _str -> runCont g inp' ks - BytesRead unused k -> BytesRead unused (go . k) - in go r0 + (<|>) 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" some p = (:) <$> p <*> many p many p = do v <- (Just <$> p) <|> pure Nothing @@ -212,16 +212,48 @@ Nothing -> pure [] Just x -> (:) x <$> many p --- | Try to execute a Get. If it fails, the consumed input will be restored. -try :: Get a -> Get a -try g = C $ \inp ks -> +-- | 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 a -> Get (Decoder a, [B.ByteString]) +runAndKeepTrack g = C $ \inp ks -> let r0 = runCont g inp (\inp' a -> Done inp' a) go !acc r = case r of - Done inp' a -> ks inp' a + Done inp' a -> ks inp (Done inp' a, reverse acc) Partial k -> Partial $ \minp -> go (maybe acc (:acc) minp) (k minp) - Fail _ s -> Fail (B.concat (inp : reverse acc)) s + 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 () +pushBack [] = C $ \ inp ks -> ks inp () +pushBack bs = C $ \ inp ks -> ks (B.concat (inp : bs)) () +{-# INLINE pushBack #-} + +-- | Run the given decoder, but without consuming its input. If the given +-- decoder fails, then so will this function. +lookAhead :: Get a -> Get 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. +lookAheadM :: Get (Maybe a) -> Get (Maybe a) +lookAheadM g = do + (decoder, bs) <- runAndKeepTrack g + case decoder of + Done _ Nothing -> pushBack bs >> return Nothing + Done inp (Just x) -> C $ \_ ks -> ks inp (Just x) + Fail inp s -> C $ \_ _ -> Fail inp s + _ -> error "Binary: impossible" -- | DEPRECATED. Get the number of bytes of remaining input. -- Note that this is an expensive function to use as in order to calculate how diff --git a/tests/Action.hs b/tests/Action.hs --- a/tests/Action.hs +++ b/tests/Action.hs @@ -2,8 +2,10 @@ module Action where import Control.Applicative +import Control.Monad import Test.QuickCheck +import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.Binary.Get as Binary @@ -11,8 +13,12 @@ import Arbitrary() data Action - = GetByteString Int + = Actions [Action] + | GetByteString Int | Try [Action] [Action] + | LookAhead [Action] + -- | First argument is True if this action returns Just, otherwise False. + | LookAheadM Bool [Action] | BytesRead | Fail deriving (Show, Eq) @@ -20,11 +26,17 @@ instance Arbitrary Action where shrink action = case action of - GetByteString n -> [ GetByteString n' | n' <- shrink n, n > 0 ] + 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] + Try [Fail] b -> Actions b : [ Try [Fail] b' | b' <- shrink b ] Try a b -> - [ Try a' b' | a' <- shrink a, b' <- shrink 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 ] @@ -32,8 +44,11 @@ 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 BytesRead -> willFail xs Fail -> True @@ -41,23 +56,35 @@ max_len [] = 0 max_len (x:xs) = case x of + Actions x' -> max_len x' + max_len xs GetByteString n -> n + max_len 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) actual_len :: [Action] -> Maybe Int -actual_len = go 0 +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 + Try a b | not (willFail a) -> (+) <$> actual_len a <*> rest + | not (willFail b) -> (+) <$> actual_len b <*> rest + | otherwise -> Nothing + where - go !s [] = Just s - go !s (x:xs) = - case x of - GetByteString n -> go (s+n) xs - Fail -> Nothing - BytesRead -> go s xs - Try a b | not (willFail a) -> liftA2 (+) (go s a) (actual_len xs) - | not (willFail b) -> liftA2 (+) (go s b) (actual_len xs) - | otherwise -> Nothing + rest = actual_len xs -- | Build binary programs and compare running them to running a (hopefully) -- identical model. @@ -68,23 +95,45 @@ forAllShrink gen_actions shrink $ \ actions -> forAll arbitrary $ \ lbs -> L.length lbs >= fromIntegral (max_len actions) ==> - case Binary.runGet (eval actions) lbs of + let allInput = B.concat (L.toChunks lbs) in + case Binary.runGet (eval allInput actions) lbs of () -> True -eval :: [Action] -> Binary.Get () -eval = go 0 +-- | Evaluate (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 where go _ [] = return () go pos (x:xs) = case x of - GetByteString n -> - Binary.getByteString n >> go (pos+n) xs + Actions a -> go pos (a++xs) + GetByteString n -> do + -- Run the operation in the Get monad... + actual <- Binary.getByteString n + let expected = B.take n . B.drop pos $ str + -- ... and compare that we got what we expected. + when (actual /= expected) $ error "actual /= expected" + go (pos+n) xs BytesRead -> do pos' <- Binary.bytesRead if (pos == fromIntegral pos') then go pos xs else error $ "expected " ++ show pos ++ " but got " ++ show pos' Fail -> fail "fail" + LookAhead a -> do + _ <- Binary.lookAhead (go pos a) + go pos xs + LookAheadM b a -> do + let f True = 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 Try a b -> do len <- leg pos a <|> leg pos b case len of @@ -103,4 +152,9 @@ , 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) ] ++ [ return [Fail] | inTry ] diff --git a/tests/Arbitrary.hs b/tests/Arbitrary.hs --- a/tests/Arbitrary.hs +++ b/tests/Arbitrary.hs @@ -8,7 +8,7 @@ import qualified Data.ByteString.Lazy as L instance Arbitrary L.ByteString where - arbitrary = arbitrary >>= return . L.fromChunks . filter (not. B.null) -- maintain the invariant. + arbitrary = fmap L.fromChunks arbitrary instance Arbitrary B.ByteString where arbitrary = B.pack `fmap` arbitrary diff --git a/tests/File.hs b/tests/File.hs new file mode 100644 --- /dev/null +++ b/tests/File.hs @@ -0,0 +1,39 @@ +module Main where + +import Control.Applicative +import Test.HUnit +import System.Directory ( getTemporaryDirectory ) +import System.FilePath ( () ) + +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 ()