From 5faf6a665e87ac67cbe5cf67cffb2aa90b56de92 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Tue, 30 Oct 2018 15:57:08 -0400 Subject: Refactored xdelta function, enables lazier streaming. --- haskell/Data/VCDIFF.hs | 79 ++++++++++++++++++++++++++++++++++++++---- haskell/Data/VCDIFF/XDelta.hsc | 3 +- haskell/examples/testdiff.hs | 15 ++++++-- xdelta.cabal | 2 +- 4 files changed, 87 insertions(+), 12 deletions(-) diff --git a/haskell/Data/VCDIFF.hs b/haskell/Data/VCDIFF.hs index 6b95ede..f06be9c 100644 --- a/haskell/Data/VCDIFF.hs +++ b/haskell/Data/VCDIFF.hs @@ -24,6 +24,7 @@ module Data.VCDIFF , computeDiff , applyPatch) where +-- import Debug.Trace import Control.Monad import Control.Monad.Primitive import Control.Monad.ST @@ -34,6 +35,7 @@ import qualified Data.ByteString.Unsafe as B import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Lazy as L import Data.Coerce +import Data.Function import Data.Int import qualified Data.IntMap as IntMap import Data.Monoid @@ -87,6 +89,7 @@ config_stream cfg = do xd3_abort_stream sptr xd3_close_stream sptr xd3_free_stream sptr + putStrLn $ "finalized " ++ show sptr keepAlive srcvar s fp <- newForeignPtr sptr finalize return Stream @@ -104,7 +107,7 @@ set_source :: PrimMonad m => -> Usize_t -- ^ block size -> Xoff_t -- ^ maximum visible buffer (Suggested: set same as block size). -- Rounds up to approx 16k. - -> m () + -> m (Source m) set_source stream nm blksz maxwinsz = do src <- newSource nm blksz maxwinsz {- @@ -115,6 +118,7 @@ set_source stream nm blksz maxwinsz = do let strm = streamArrayPtr $ streamArray stream unsafeIOToPrim (xd3_set_source strm $ sourcePtr src) writeMutVar (streamSource stream) (Just src) + return src data XDeltaMethods m u = XDeltaMethods { xConfig :: Config @@ -159,17 +163,78 @@ withByteString d act = unsafeIOToPrim $ touchForeignPtr fp return a -xdelta :: (PrimBase m, Monoid u) => XDeltaMethods m u -> (Stream m -> m ErrorCode) -> [B.ByteString] -> m u -xdelta x xxcode_input ds = do +outputChunks :: (Monoid b, Num t, PrimMonad m, Show b) => + StreamArray m + -> (m b -> m b) + -> m ErrorCode + -> (Ptr Word8 -> t -> m b) + -> (ErrorCode -> m b) + -> m b +outputChunks strm interleave encode output next = fix $ \loop -> do + encode >>= \case + XD3_OUTPUT -> do u1 <- nextOut strm $ \(p,len) -> output p (fromIntegral len) + trace ("u1 = " ++ show u1) $ return () + u <- interleave $ loop + return $ u1 <> u + XD3_GOTHEADER -> trace "XD3_GOTHEADER" loop + XD3_WINSTART -> trace "XD3_WINSTART" loop + XD3_WINFINISH -> trace "XD3_WINFINISH" loop + xd3 -> next xd3 + +withBlocks :: PrimBase m => B.ByteString -> Maybe B.ByteString -> m a -> m a +withBlocks d mblk f = withByteString d $ \_ _ -> case mblk of + Just blk -> withByteString blk $ \_ _ -> f + Nothing -> f + +updateBlock :: (Monoid u, PrimBase m, Show u) => + Stream m + -> m ErrorCode + -> Maybe B.ByteString + -> XDeltaMethods m u + -> B.ByteString + -> [B.ByteString] + -> ErrorCode + -> m u +updateBlock stream code_input mblk x _ [] XD3_INPUT = return mempty +updateBlock stream code_input mblk x _ (d:ds) XD3_INPUT = trace "XD3_INPUT" $ do + withByteString d $ \p len -> avail_input (streamArray stream) p len + when (null ds) $ setFlush (streamArray stream) True + outputChunks (streamArray stream) (xInterleave x) + (withBlocks d mblk code_input) + (xOutput x) + $ updateBlock stream code_input mblk x d ds +updateBlock stream code_input mblk x d ds XD3_GETSRCBLK = do + Just n <- requestedBlockNumber stream + let blk = xGetSource x n + withByteString blk $ \p len -> do + pokeCurrentBlock stream $ CurrentBlock n len p + trace ("XD3_GETSRCBLK " ++ show (n,len,p,xBlockSize x)) $ return () + when (len < xBlockSize x) $ do + Just src <- readMutVar $ streamSource stream + sourceWriteEOFKnown src True + outputChunks (streamArray stream) (xInterleave x) + (withBlocks d (Just blk) code_input) + (xOutput x) + $ updateBlock stream code_input mblk x d ds +updateBlock stream code_input mblk x d ds e = trace (show e) $ do + s <- errorString (streamArray stream) + xOnError x e s + +trace _ = id + +xdelta :: (Show u, PrimBase m, Monoid u) => XDeltaMethods m u -> (Stream m -> m ErrorCode) -> [B.ByteString] -> m u +xdelta x xxcode_input ds = trace ("ds = "++show ds) $ do mstream <- config_stream (xConfig x) either (\e _ -> xOnError x e "config_stream failed") (flip ($)) mstream $ \stream -> do - set_source stream "VCDIFF" (xBlockSize x) (xBlockSize x) + src <- set_source stream "VCDIFF" (xBlockSize x) (xBlockSize x) + updateBlock stream (xxcode_input stream) Nothing x B.empty ds XD3_INPUT + {- let go withBlk [] = return mempty go withBlk (d:ds) = do let (fp,off,len) = B.toForeignPtr d - eof = null ds + eof = null ds || len < fromIntegral (xBlockSize x) when eof $ setFlush (streamArray stream) True withByteString d $ \indata len -> do avail_input (streamArray stream) indata len @@ -203,7 +268,7 @@ xdelta x xxcode_input ds = do s <- errorString (streamArray stream) xOnError x e s xInterleave x $ go id ds - + -} decode_input :: PrimMonad m => Stream m -> m ErrorCode decode_input stream = @@ -271,7 +336,7 @@ xdeltaPure codec cfg source input = <$> B.packCStringLen (castPtr ptr,len) , xOnError = \e s -> return (Result L.empty (Just (e,s))) , xBlockSize = bsize - , xInterleave = unsafeInterleaveST + , xInterleave = id -- unsafeInterleaveST } in runST $ xdelta x codec ds diff --git a/haskell/Data/VCDIFF/XDelta.hsc b/haskell/Data/VCDIFF/XDelta.hsc index b406c1d..c66dab2 100644 --- a/haskell/Data/VCDIFF/XDelta.hsc +++ b/haskell/Data/VCDIFF/XDelta.hsc @@ -75,7 +75,8 @@ sourceWriteCurrentBlock :: PrimMonad m => Source m -> CurrentBlock -> m () sourceWriteCurrentBlock (Source src) (CurrentBlock no sz ptr) = do writeAtByte src (#{off xd3_source, curblkno}) no writeAtByte src (#{off xd3_source, onblk}) sz - writeAtByte src (#{off xd3_source, curblk}) ptr + when (ptr /= nullPtr) + $ writeAtByte src (#{off xd3_source, curblk}) ptr sourceWriteEOFKnown :: PrimMonad m => Source m -> Bool -> m () sourceWriteEOFKnown (Source src) False = writeAtByte src (#{off xd3_source, eof_known}) (0 :: #{type int}) diff --git a/haskell/examples/testdiff.hs b/haskell/examples/testdiff.hs index 9d580ba..08229d3 100644 --- a/haskell/examples/testdiff.hs +++ b/haskell/examples/testdiff.hs @@ -17,7 +17,7 @@ delta :: Result VCDIFF delta = computeDiff defaultConfig source target delta2 :: Result VCDIFF -delta2 = computeDiff defaultConfig source target +delta2 = computeDiff defaultConfig source target delta3 :: Result VCDIFF delta3 = computeDiff defaultConfig { flags = XD3_ADLER32 } source target @@ -25,6 +25,9 @@ delta3 = computeDiff defaultConfig { flags = XD3_ADLER32 } source target delta4 :: Result VCDIFF delta4 = computeDiff defaultConfig { flags = XD3_ADLER32 } source target +delta5 :: Result VCDIFF +delta5 = computeDiff defaultConfig { flags = XD3_ADLER32 } source target + dump title bs kont = do @@ -35,14 +38,20 @@ dump title bs kont = do main = do dump "source" source $ putStrLn "" dump "target" target $ putStrLn "" - go source "default" delta - go source "default" delta2 go source "XD3_ADLER32" delta3 go source "XD3_ADLER32" delta4 + go source "XD3_ADLER32" delta5 + go source "default" delta + go source "default" delta2 + {- go source2 "default" delta go source2 "default" delta2 go source2 "XD3_ADLER32" delta3 go source2 "XD3_ADLER32" delta4 + -} + print source + print source2 + print target go source flgs delta = do putStrLn "" diff --git a/xdelta.cabal b/xdelta.cabal index d54f3f6..0097e9f 100644 --- a/xdelta.cabal +++ b/xdelta.cabal @@ -21,7 +21,7 @@ library build-tools: hsc2hs include-dirs: haskell . - cpp-options: -DNOT_MAIN=1 -DREGRESSION_TEST=1 -DSECONDARY_DJW=1 -DSECONDARY_FGK=1 -DXD3_MAIN=1 -DXD3_DEBUG=0 -DHAVE_CONFIG + cpp-options: -DNOT_MAIN=1 -DREGRESSION_TEST=1 -DSECONDARY_DJW=1 -DSECONDARY_FGK=1 -DXD3_MAIN=1 -DXD3_DEBUG=3 -DHAVE_CONFIG cxx-options: -Wno-literal-suffix -g cxx-sources: haskell/xdelta3.cc -- cgit v1.2.3