Refactored xdelta function, enables lazier streaming.

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