diff options
Diffstat (limited to 'haskell/Data/VCDIFF.hs')
-rw-r--r-- | haskell/Data/VCDIFF.hs | 79 |
1 files changed, 72 insertions, 7 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 | |||
24 | , computeDiff | 24 | , computeDiff |
25 | , applyPatch) where | 25 | , applyPatch) where |
26 | 26 | ||
27 | -- import Debug.Trace | ||
27 | import Control.Monad | 28 | import Control.Monad |
28 | import Control.Monad.Primitive | 29 | import Control.Monad.Primitive |
29 | import Control.Monad.ST | 30 | import Control.Monad.ST |
@@ -34,6 +35,7 @@ import qualified Data.ByteString.Unsafe as B | |||
34 | import qualified Data.ByteString.Internal as B | 35 | import qualified Data.ByteString.Internal as B |
35 | import qualified Data.ByteString.Lazy as L | 36 | import qualified Data.ByteString.Lazy as L |
36 | import Data.Coerce | 37 | import Data.Coerce |
38 | import Data.Function | ||
37 | import Data.Int | 39 | import Data.Int |
38 | import qualified Data.IntMap as IntMap | 40 | import qualified Data.IntMap as IntMap |
39 | import Data.Monoid | 41 | import Data.Monoid |
@@ -87,6 +89,7 @@ config_stream cfg = do | |||
87 | xd3_abort_stream sptr | 89 | xd3_abort_stream sptr |
88 | xd3_close_stream sptr | 90 | xd3_close_stream sptr |
89 | xd3_free_stream sptr | 91 | xd3_free_stream sptr |
92 | putStrLn $ "finalized " ++ show sptr | ||
90 | keepAlive srcvar s | 93 | keepAlive srcvar s |
91 | fp <- newForeignPtr sptr finalize | 94 | fp <- newForeignPtr sptr finalize |
92 | return Stream | 95 | return Stream |
@@ -104,7 +107,7 @@ set_source :: PrimMonad m => | |||
104 | -> Usize_t -- ^ block size | 107 | -> Usize_t -- ^ block size |
105 | -> Xoff_t -- ^ maximum visible buffer (Suggested: set same as block size). | 108 | -> Xoff_t -- ^ maximum visible buffer (Suggested: set same as block size). |
106 | -- Rounds up to approx 16k. | 109 | -- Rounds up to approx 16k. |
107 | -> m () | 110 | -> m (Source m) |
108 | set_source stream nm blksz maxwinsz = do | 111 | set_source stream nm blksz maxwinsz = do |
109 | src <- newSource nm blksz maxwinsz | 112 | src <- newSource nm blksz maxwinsz |
110 | {- | 113 | {- |
@@ -115,6 +118,7 @@ set_source stream nm blksz maxwinsz = do | |||
115 | let strm = streamArrayPtr $ streamArray stream | 118 | let strm = streamArrayPtr $ streamArray stream |
116 | unsafeIOToPrim (xd3_set_source strm $ sourcePtr src) | 119 | unsafeIOToPrim (xd3_set_source strm $ sourcePtr src) |
117 | writeMutVar (streamSource stream) (Just src) | 120 | writeMutVar (streamSource stream) (Just src) |
121 | return src | ||
118 | 122 | ||
119 | data XDeltaMethods m u = XDeltaMethods | 123 | data XDeltaMethods m u = XDeltaMethods |
120 | { xConfig :: Config | 124 | { xConfig :: Config |
@@ -159,17 +163,78 @@ withByteString d act = | |||
159 | unsafeIOToPrim $ touchForeignPtr fp | 163 | unsafeIOToPrim $ touchForeignPtr fp |
160 | return a | 164 | return a |
161 | 165 | ||
162 | xdelta :: (PrimBase m, Monoid u) => XDeltaMethods m u -> (Stream m -> m ErrorCode) -> [B.ByteString] -> m u | 166 | outputChunks :: (Monoid b, Num t, PrimMonad m, Show b) => |
163 | xdelta x xxcode_input ds = do | 167 | StreamArray m |
168 | -> (m b -> m b) | ||
169 | -> m ErrorCode | ||
170 | -> (Ptr Word8 -> t -> m b) | ||
171 | -> (ErrorCode -> m b) | ||
172 | -> m b | ||
173 | outputChunks strm interleave encode output next = fix $ \loop -> do | ||
174 | encode >>= \case | ||
175 | XD3_OUTPUT -> do u1 <- nextOut strm $ \(p,len) -> output p (fromIntegral len) | ||
176 | trace ("u1 = " ++ show u1) $ return () | ||
177 | u <- interleave $ loop | ||
178 | return $ u1 <> u | ||
179 | XD3_GOTHEADER -> trace "XD3_GOTHEADER" loop | ||
180 | XD3_WINSTART -> trace "XD3_WINSTART" loop | ||
181 | XD3_WINFINISH -> trace "XD3_WINFINISH" loop | ||
182 | xd3 -> next xd3 | ||
183 | |||
184 | withBlocks :: PrimBase m => B.ByteString -> Maybe B.ByteString -> m a -> m a | ||
185 | withBlocks d mblk f = withByteString d $ \_ _ -> case mblk of | ||
186 | Just blk -> withByteString blk $ \_ _ -> f | ||
187 | Nothing -> f | ||
188 | |||
189 | updateBlock :: (Monoid u, PrimBase m, Show u) => | ||
190 | Stream m | ||
191 | -> m ErrorCode | ||
192 | -> Maybe B.ByteString | ||
193 | -> XDeltaMethods m u | ||
194 | -> B.ByteString | ||
195 | -> [B.ByteString] | ||
196 | -> ErrorCode | ||
197 | -> m u | ||
198 | updateBlock stream code_input mblk x _ [] XD3_INPUT = return mempty | ||
199 | updateBlock stream code_input mblk x _ (d:ds) XD3_INPUT = trace "XD3_INPUT" $ do | ||
200 | withByteString d $ \p len -> avail_input (streamArray stream) p len | ||
201 | when (null ds) $ setFlush (streamArray stream) True | ||
202 | outputChunks (streamArray stream) (xInterleave x) | ||
203 | (withBlocks d mblk code_input) | ||
204 | (xOutput x) | ||
205 | $ updateBlock stream code_input mblk x d ds | ||
206 | updateBlock stream code_input mblk x d ds XD3_GETSRCBLK = do | ||
207 | Just n <- requestedBlockNumber stream | ||
208 | let blk = xGetSource x n | ||
209 | withByteString blk $ \p len -> do | ||
210 | pokeCurrentBlock stream $ CurrentBlock n len p | ||
211 | trace ("XD3_GETSRCBLK " ++ show (n,len,p,xBlockSize x)) $ return () | ||
212 | when (len < xBlockSize x) $ do | ||
213 | Just src <- readMutVar $ streamSource stream | ||
214 | sourceWriteEOFKnown src True | ||
215 | outputChunks (streamArray stream) (xInterleave x) | ||
216 | (withBlocks d (Just blk) code_input) | ||
217 | (xOutput x) | ||
218 | $ updateBlock stream code_input mblk x d ds | ||
219 | updateBlock stream code_input mblk x d ds e = trace (show e) $ do | ||
220 | s <- errorString (streamArray stream) | ||
221 | xOnError x e s | ||
222 | |||
223 | trace _ = id | ||
224 | |||
225 | xdelta :: (Show u, PrimBase m, Monoid u) => XDeltaMethods m u -> (Stream m -> m ErrorCode) -> [B.ByteString] -> m u | ||
226 | xdelta x xxcode_input ds = trace ("ds = "++show ds) $ do | ||
164 | mstream <- config_stream (xConfig x) | 227 | mstream <- config_stream (xConfig x) |
165 | either (\e _ -> xOnError x e "config_stream failed") | 228 | either (\e _ -> xOnError x e "config_stream failed") |
166 | (flip ($)) | 229 | (flip ($)) |
167 | mstream $ \stream -> do | 230 | mstream $ \stream -> do |
168 | set_source stream "VCDIFF" (xBlockSize x) (xBlockSize x) | 231 | src <- set_source stream "VCDIFF" (xBlockSize x) (xBlockSize x) |
232 | updateBlock stream (xxcode_input stream) Nothing x B.empty ds XD3_INPUT | ||
233 | {- | ||
169 | let go withBlk [] = return mempty | 234 | let go withBlk [] = return mempty |
170 | go withBlk (d:ds) = do | 235 | go withBlk (d:ds) = do |
171 | let (fp,off,len) = B.toForeignPtr d | 236 | let (fp,off,len) = B.toForeignPtr d |
172 | eof = null ds | 237 | eof = null ds || len < fromIntegral (xBlockSize x) |
173 | when eof $ setFlush (streamArray stream) True | 238 | when eof $ setFlush (streamArray stream) True |
174 | withByteString d $ \indata len -> do | 239 | withByteString d $ \indata len -> do |
175 | avail_input (streamArray stream) indata len | 240 | avail_input (streamArray stream) indata len |
@@ -203,7 +268,7 @@ xdelta x xxcode_input ds = do | |||
203 | s <- errorString (streamArray stream) | 268 | s <- errorString (streamArray stream) |
204 | xOnError x e s | 269 | xOnError x e s |
205 | xInterleave x $ go id ds | 270 | xInterleave x $ go id ds |
206 | 271 | -} | |
207 | 272 | ||
208 | decode_input :: PrimMonad m => Stream m -> m ErrorCode | 273 | decode_input :: PrimMonad m => Stream m -> m ErrorCode |
209 | decode_input stream = | 274 | decode_input stream = |
@@ -271,7 +336,7 @@ xdeltaPure codec cfg source input = | |||
271 | <$> B.packCStringLen (castPtr ptr,len) | 336 | <$> B.packCStringLen (castPtr ptr,len) |
272 | , xOnError = \e s -> return (Result L.empty (Just (e,s))) | 337 | , xOnError = \e s -> return (Result L.empty (Just (e,s))) |
273 | , xBlockSize = bsize | 338 | , xBlockSize = bsize |
274 | , xInterleave = unsafeInterleaveST | 339 | , xInterleave = id -- unsafeInterleaveST |
275 | } | 340 | } |
276 | in runST $ xdelta x codec ds | 341 | in runST $ xdelta x codec ds |
277 | 342 | ||