diff options
Diffstat (limited to 'haskell/Data/XDelta.hsc')
-rw-r--r-- | haskell/Data/XDelta.hsc | 44 |
1 files changed, 22 insertions, 22 deletions
diff --git a/haskell/Data/XDelta.hsc b/haskell/Data/XDelta.hsc index 4ebdd51..bb08cb6 100644 --- a/haskell/Data/XDelta.hsc +++ b/haskell/Data/XDelta.hsc | |||
@@ -30,7 +30,6 @@ import Data.STRef | |||
30 | import qualified Data.Text as T | 30 | import qualified Data.Text as T |
31 | import Data.Text.Encoding | 31 | import Data.Text.Encoding |
32 | import Data.Word | 32 | import Data.Word |
33 | import Debug.Trace | ||
34 | import Foreign.C.Types | 33 | import Foreign.C.Types |
35 | import Foreign.C.String | 34 | import Foreign.C.String |
36 | import Foreign.ForeignPtr (withForeignPtr) | 35 | import Foreign.ForeignPtr (withForeignPtr) |
@@ -53,7 +52,10 @@ import XDelta.Types | |||
53 | 52 | ||
54 | data Stream m = Stream | 53 | data Stream m = Stream |
55 | { streamArray :: MutableByteArray (PrimState m) | 54 | { streamArray :: MutableByteArray (PrimState m) |
56 | , streamPtr :: ForeignPtr Xd3Stream | 55 | , streamPtr :: ForeignPtr Xd3Stream -- ^ HACK: this is only used to attach a finalizer |
56 | -- to 'streamArray'. Don't use this pointer. | ||
57 | -- This would be unnecessary if I could create a | ||
58 | -- MutableByteArray with a finalizer attached. | ||
57 | , streamSource :: MutVar (PrimState m) (Maybe (MutableByteArray (PrimState m))) | 59 | , streamSource :: MutVar (PrimState m) (Maybe (MutableByteArray (PrimState m))) |
58 | } | 60 | } |
59 | 61 | ||
@@ -138,6 +140,7 @@ config_stream cfg = do | |||
138 | xd3_abort_stream sptr | 140 | xd3_abort_stream sptr |
139 | xd3_close_stream sptr | 141 | xd3_close_stream sptr |
140 | xd3_free_stream sptr | 142 | xd3_free_stream sptr |
143 | seq s $ return () -- Keep array s alive until the ffi functions finish. | ||
141 | fp <- newForeignPtr sptr finalize | 144 | fp <- newForeignPtr sptr finalize |
142 | return Stream | 145 | return Stream |
143 | { streamArray = s | 146 | { streamArray = s |
@@ -278,7 +281,8 @@ xdelta x xxcode_input ds = do | |||
278 | (flip ($)) | 281 | (flip ($)) |
279 | mstream $ \stream -> do | 282 | mstream $ \stream -> do |
280 | set_source stream "xdelta" (xBlockSize x) (xBlockSize x) | 283 | set_source stream "xdelta" (xBlockSize x) (xBlockSize x) |
281 | let go withBlk (d:ds) = do | 284 | let go withBlk [] = return mempty |
285 | go withBlk (d:ds) = do | ||
282 | let (fp,off,len) = B.toForeignPtr d | 286 | let (fp,off,len) = B.toForeignPtr d |
283 | eof = null ds | 287 | eof = null ds |
284 | when eof $ setFlush stream True | 288 | when eof $ setFlush stream True |
@@ -291,9 +295,8 @@ xdelta x xxcode_input ds = do | |||
291 | XD3_INPUT -> if (not eof) then go withBlk ds else return mempty | 295 | XD3_INPUT -> if (not eof) then go withBlk ds else return mempty |
292 | XD3_OUTPUT -> do | 296 | XD3_OUTPUT -> do |
293 | m' <- nextOut stream (\(p,len) -> xOutput x p (fromIntegral len)) | 297 | m' <- nextOut stream (\(p,len) -> xOutput x p (fromIntegral len)) |
294 | ms <- xInterleave x $ undefined -- go2 withBlk eof ds | 298 | ms <- xInterleave x $ go2 withBlk eof ds |
295 | return $ trace "chunk" m' <> ms | 299 | return $ m' <> ms |
296 | -- XXX: This output is to test for laziness. | ||
297 | XD3_GETSRCBLK -> do | 300 | XD3_GETSRCBLK -> do |
298 | Just n <- requestedBlockNumber stream | 301 | Just n <- requestedBlockNumber stream |
299 | let blk = xGetSource x n | 302 | let blk = xGetSource x n |
@@ -314,7 +317,7 @@ xdelta x xxcode_input ds = do | |||
314 | e -> do | 317 | e -> do |
315 | s <- errorString stream | 318 | s <- errorString stream |
316 | xOnError x e s | 319 | xOnError x e s |
317 | go id ds | 320 | xInterleave x $ go id ds |
318 | 321 | ||
319 | 322 | ||
320 | foreign import ccall "xdelta3.h xd3_decode_input" xd3_decode_input :: Ptr Xd3Stream -> IO ErrorCode | 323 | foreign import ccall "xdelta3.h xd3_decode_input" xd3_decode_input :: Ptr Xd3Stream -> IO ErrorCode |
@@ -342,39 +345,36 @@ computeDiff cfg source patched = fmap XDelta $ xdeltaPure encode_input cfg sourc | |||
342 | applyPatch :: Config -> L.ByteString -> XDelta -> XDeltaFailable L.ByteString | 345 | applyPatch :: Config -> L.ByteString -> XDelta -> XDeltaFailable L.ByteString |
343 | applyPatch cfg source (XDelta delta) = xdeltaPure decode_input cfg source delta | 346 | applyPatch cfg source (XDelta delta) = xdeltaPure decode_input cfg source delta |
344 | 347 | ||
345 | data XDeltaFailable x = XError ErrorCode String | 348 | data XDeltaFailable x = XResult { xresult :: x, xerror :: (Maybe (ErrorCode,String)) } |
346 | | XSuccess x | ||
347 | deriving (Show,Functor) | 349 | deriving (Show,Functor) |
348 | 350 | ||
349 | instance Monoid x => Monoid (XDeltaFailable x) where | 351 | instance Monoid x => Monoid (XDeltaFailable x) where |
350 | mempty = XSuccess mempty | 352 | mempty = XResult mempty Nothing |
351 | mappend (XSuccess x) (XSuccess y) = XSuccess $ mappend x y | 353 | mappend (XResult x xe) y = XResult (mappend x $ xresult y) (maybe (xerror y) Just xe) |
352 | mappend x@XError{} _ = x | ||
353 | mappend _ y@XError{} = y | ||
354 | 354 | ||
355 | xdeltaPure :: (forall s. Stream (ST s) -> ST s ErrorCode) -> Config -> L.ByteString -> L.ByteString -> XDeltaFailable L.ByteString | 355 | xdeltaPure :: (forall s. Stream (ST s) -> ST s ErrorCode) -> Config -> L.ByteString -> L.ByteString -> XDeltaFailable L.ByteString |
356 | xdeltaPure codec cfg source delta = | 356 | xdeltaPure codec cfg source delta = |
357 | let smap = IntMap.fromList $ zip [0..] (chunksOf 16 source) | 357 | let smap = IntMap.fromList $ zip [0..] (chunksOf bsize source) |
358 | bsize = 4096 | ||
358 | x :: XDeltaMethods (ST s) (XDeltaFailable L.ByteString) | 359 | x :: XDeltaMethods (ST s) (XDeltaFailable L.ByteString) |
359 | x = XDeltaMethods | 360 | x = XDeltaMethods |
360 | { xConfig = cfg | 361 | { xConfig = cfg |
361 | , xGetSource = \i -> case IntMap.lookup (fromIntegral i) smap of | 362 | , xGetSource = \i -> case IntMap.lookup (fromIntegral i) smap of |
362 | Nothing -> B.empty | 363 | Nothing -> B.empty |
363 | Just bs -> bs | 364 | Just bs -> bs |
364 | , xOutput = \ptr len -> unsafeIOToST $ XSuccess . L.fromStrict <$> B.packCStringLen (castPtr ptr,len) | 365 | , xOutput = \ptr len -> unsafeIOToST $ flip XResult Nothing . L.fromStrict <$> B.packCStringLen (castPtr ptr,len) |
365 | , xOnError = \e s -> return (XError e s) -- :: ErrorCode -> String -> m u | 366 | , xOnError = \e s -> return (XResult L.empty (Just (e,s))) -- :: ErrorCode -> String -> m u |
366 | , xBlockSize = 16 -- 4096 -- :: Usize_t | 367 | , xBlockSize = bsize -- :: Usize_t |
367 | , xInterleave = unsafeInterleaveST -- :: forall a. m a -> m a | 368 | , xInterleave = unsafeInterleaveST -- :: forall a. m a -> m a |
368 | -- XXX: Why isn't unsafeInterleaveST making it lazy? | ||
369 | } | 369 | } |
370 | ds = chunksOf 16 delta -- L.toChunks delta | 370 | ds = chunksOf bsize delta -- L.toChunks delta |
371 | in runST $ xdelta x codec ds | 371 | in runST $ xdelta x codec ds |
372 | 372 | ||
373 | defaultConfig :: Config | 373 | defaultConfig :: Config |
374 | defaultConfig = Config | 374 | defaultConfig = Config |
375 | { winsize = 4096 | 375 | { winsize = XD3_DEFAULT_WINSIZE |
376 | , sprevsz = 0 | 376 | , sprevsz = XD3_DEFAULT_SPREVSZ |
377 | , iopt_size = 0 | 377 | , iopt_size = XD3_DEFAULT_IOPT_SIZE |
378 | , flags = mempty | 378 | , flags = mempty |
379 | , sec_data = CompressorConfig 0 0 0 | 379 | , sec_data = CompressorConfig 0 0 0 |
380 | , sec_inst = CompressorConfig 0 0 0 | 380 | , sec_inst = CompressorConfig 0 0 0 |