diff options
Diffstat (limited to 'haskell/Data/XDelta.hsc')
-rw-r--r-- | haskell/Data/XDelta.hsc | 81 |
1 files changed, 45 insertions, 36 deletions
diff --git a/haskell/Data/XDelta.hsc b/haskell/Data/XDelta.hsc index bb08cb6..8128a61 100644 --- a/haskell/Data/XDelta.hsc +++ b/haskell/Data/XDelta.hsc | |||
@@ -140,7 +140,7 @@ config_stream cfg = do | |||
140 | xd3_abort_stream sptr | 140 | xd3_abort_stream sptr |
141 | xd3_close_stream sptr | 141 | xd3_close_stream sptr |
142 | xd3_free_stream sptr | 142 | xd3_free_stream sptr |
143 | seq s $ return () -- Keep array s alive until the ffi functions finish. | 143 | seq srcvar $ seq s $ return () -- Keep array s alive until the ffi functions finish. |
144 | fp <- newForeignPtr sptr finalize | 144 | fp <- newForeignPtr sptr finalize |
145 | return Stream | 145 | return Stream |
146 | { streamArray = s | 146 | { streamArray = s |
@@ -166,7 +166,8 @@ foreign import ccall "xdelta3.h xd3_set_source" xd3_set_source :: Ptr Xd3Stream | |||
166 | set_source :: PrimMonad m => | 166 | set_source :: PrimMonad m => |
167 | Stream m -> String -- ^ name for debug/print purposes. | 167 | Stream m -> String -- ^ name for debug/print purposes. |
168 | -> Usize_t -- ^ block size | 168 | -> Usize_t -- ^ block size |
169 | -> Xoff_t -- ^ maximum visible buffer | 169 | -> Xoff_t -- ^ maximum visible buffer (Suggested: set same as block size). |
170 | -- Rounds up to approx 16k. | ||
170 | -> m () | 171 | -> m () |
171 | set_source stream nm blksz maxwinsz = do | 172 | set_source stream nm blksz maxwinsz = do |
172 | let bsname = encodeUtf8 $ T.pack nm | 173 | let bsname = encodeUtf8 $ T.pack nm |
@@ -280,7 +281,7 @@ xdelta x xxcode_input ds = do | |||
280 | either (\e _ -> xOnError x e "config_stream failed") | 281 | either (\e _ -> xOnError x e "config_stream failed") |
281 | (flip ($)) | 282 | (flip ($)) |
282 | mstream $ \stream -> do | 283 | mstream $ \stream -> do |
283 | set_source stream "xdelta" (xBlockSize x) (xBlockSize x) | 284 | set_source stream "VCDIFF" (xBlockSize x) (xBlockSize x) |
284 | let go withBlk [] = return mempty | 285 | let go withBlk [] = return mempty |
285 | go withBlk (d:ds) = do | 286 | go withBlk (d:ds) = do |
286 | let (fp,off,len) = B.toForeignPtr d | 287 | let (fp,off,len) = B.toForeignPtr d |
@@ -331,7 +332,8 @@ encode_input :: PrimMonad m => Stream m -> m ErrorCode | |||
331 | encode_input stream = | 332 | encode_input stream = |
332 | unsafeIOToPrim $ xd3_encode_input (ptr $ mutableByteArrayContents $ streamArray stream) | 333 | unsafeIOToPrim $ xd3_encode_input (ptr $ mutableByteArrayContents $ streamArray stream) |
333 | 334 | ||
334 | newtype XDelta = XDelta L.ByteString | 335 | -- RFC 3284 |
336 | newtype VCDIFF = VCDIFF L.ByteString | ||
335 | deriving Show | 337 | deriving Show |
336 | 338 | ||
337 | chunksOf :: Usize_t -> L.ByteString -> [B.ByteString] | 339 | chunksOf :: Usize_t -> L.ByteString -> [B.ByteString] |
@@ -339,45 +341,52 @@ chunksOf len bs | L.null bs = [] | |||
339 | | otherwise = let (b,bs') = L.splitAt (fromIntegral len) bs | 341 | | otherwise = let (b,bs') = L.splitAt (fromIntegral len) bs |
340 | in L.toStrict b : chunksOf len bs' | 342 | in L.toStrict b : chunksOf len bs' |
341 | 343 | ||
342 | computeDiff :: Config -> L.ByteString -> L.ByteString -> XDeltaFailable XDelta | 344 | computeDiff :: Config -> L.ByteString -> L.ByteString -> Result VCDIFF |
343 | computeDiff cfg source patched = fmap XDelta $ xdeltaPure encode_input cfg source patched | 345 | computeDiff cfg source patched = fmap VCDIFF $ xdeltaPure encode_input cfg source patched |
344 | 346 | ||
345 | applyPatch :: Config -> L.ByteString -> XDelta -> XDeltaFailable L.ByteString | 347 | applyPatch :: Config -> L.ByteString -> VCDIFF -> Result L.ByteString |
346 | applyPatch cfg source (XDelta delta) = xdeltaPure decode_input cfg source delta | 348 | applyPatch cfg source (VCDIFF delta) = xdeltaPure decode_input cfg source delta |
347 | 349 | ||
348 | data XDeltaFailable x = XResult { xresult :: x, xerror :: (Maybe (ErrorCode,String)) } | 350 | data Result x = Result |
349 | deriving (Show,Functor) | 351 | { result :: x -- ^ A possibly invalid result. To consume a lazy stream with fusion, avoid |
350 | 352 | -- evaluating 'resultError' until this field is fully processed. | |
351 | instance Monoid x => Monoid (XDeltaFailable x) where | 353 | , resultError :: Maybe (ErrorCode,String) |
352 | mempty = XResult mempty Nothing | 354 | -- ^ If something went wrong while producing 'result', this |
353 | mappend (XResult x xe) y = XResult (mappend x $ xresult y) (maybe (xerror y) Just xe) | 355 | -- is an error code and message indicating what. |
354 | 356 | } deriving (Show,Functor) | |
355 | xdeltaPure :: (forall s. Stream (ST s) -> ST s ErrorCode) -> Config -> L.ByteString -> L.ByteString -> XDeltaFailable L.ByteString | 357 | |
356 | xdeltaPure codec cfg source delta = | 358 | instance Monoid x => Monoid (Result x) where |
357 | let smap = IntMap.fromList $ zip [0..] (chunksOf bsize source) | 359 | mempty = Result mempty Nothing |
358 | bsize = 4096 | 360 | mappend (Result x xe) y = Result (mappend x $ result y) (maybe (resultError y) Just xe) |
359 | x :: XDeltaMethods (ST s) (XDeltaFailable L.ByteString) | 361 | |
362 | xdeltaPure :: (forall s. Stream (ST s) -> ST s ErrorCode) -> Config -> L.ByteString -> L.ByteString -> Result L.ByteString | ||
363 | xdeltaPure codec cfg source input = | ||
364 | let bsize = chunk_size cfg | ||
365 | ds = chunksOf bsize input | ||
366 | smap = IntMap.fromList $ zip [0..] (chunksOf bsize source) | ||
367 | x :: XDeltaMethods (ST s) (Result L.ByteString) | ||
360 | x = XDeltaMethods | 368 | x = XDeltaMethods |
361 | { xConfig = cfg | 369 | { xConfig = cfg |
362 | , xGetSource = \i -> case IntMap.lookup (fromIntegral i) smap of | 370 | , xGetSource = \i -> case IntMap.lookup (fromIntegral i) smap of |
363 | Nothing -> B.empty | 371 | Nothing -> B.empty |
364 | Just bs -> bs | 372 | Just bs -> bs |
365 | , xOutput = \ptr len -> unsafeIOToST $ flip XResult Nothing . L.fromStrict <$> B.packCStringLen (castPtr ptr,len) | 373 | , xOutput = \ptr len -> unsafeIOToST $ flip Result Nothing . L.fromStrict |
366 | , xOnError = \e s -> return (XResult L.empty (Just (e,s))) -- :: ErrorCode -> String -> m u | 374 | <$> B.packCStringLen (castPtr ptr,len) |
367 | , xBlockSize = bsize -- :: Usize_t | 375 | , xOnError = \e s -> return (Result L.empty (Just (e,s))) |
368 | , xInterleave = unsafeInterleaveST -- :: forall a. m a -> m a | 376 | , xBlockSize = bsize |
377 | , xInterleave = unsafeInterleaveST | ||
369 | } | 378 | } |
370 | ds = chunksOf bsize delta -- L.toChunks delta | ||
371 | in runST $ xdelta x codec ds | 379 | in runST $ xdelta x codec ds |
372 | 380 | ||
373 | defaultConfig :: Config | 381 | defaultConfig :: Config |
374 | defaultConfig = Config | 382 | defaultConfig = Config |
375 | { winsize = XD3_DEFAULT_WINSIZE | 383 | { winsize = XD3_DEFAULT_WINSIZE |
376 | , sprevsz = XD3_DEFAULT_SPREVSZ | 384 | , sprevsz = XD3_DEFAULT_SPREVSZ |
377 | , iopt_size = XD3_DEFAULT_IOPT_SIZE | 385 | , iopt_size = XD3_DEFAULT_IOPT_SIZE |
378 | , flags = mempty | 386 | , flags = mempty |
379 | , sec_data = CompressorConfig 0 0 0 | 387 | , sec_data = CompressorConfig 0 0 0 |
380 | , sec_inst = CompressorConfig 0 0 0 | 388 | , sec_inst = CompressorConfig 0 0 0 |
381 | , sec_addr = CompressorConfig 0 0 0 | 389 | , sec_addr = CompressorConfig 0 0 0 |
382 | , smatch_cfg = Right SMATCH_DEFAULT | 390 | , smatch_cfg = Right SMATCH_DEFAULT |
391 | , chunk_size = 4096 | ||
383 | } | 392 | } |