1 files changed, 69 insertions, 28 deletions

diff --git a/haskell/Data/XDelta.hsc b/haskell/Data/XDelta.hsc
index 4d9ffe2..4ebdd51 100644
--- a/haskell/Data/XDelta.hsc
+++ b/haskell/Data/XDelta.hsc
@@ -5,6 +5,8 @@
 {-# LANGUAGE NondecreasingIndentation   #-}
 {-# LANGUAGE PatternSynonyms            #-}
 {-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveFunctor #-}
 module Data.XDelta where
 
 import Control.Monad
@@ -18,6 +20,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.Int
 import qualified Data.IntMap as IntMap
 import Data.Monoid
 import Data.Primitive.Addr
@@ -27,6 +30,7 @@ import Data.STRef
 import qualified Data.Text as T
 import Data.Text.Encoding
 import Data.Word
+import Debug.Trace
 import Foreign.C.Types
 import Foreign.C.String
 import Foreign.ForeignPtr (withForeignPtr)
@@ -205,23 +209,27 @@ setFlush = setFlag XD3_FLUSH
 setSkipWindow :: PrimMonad m => Stream m -> Bool -> m ()
 setSkipWindow = setFlag XD3_SKIP_WINDOW
 
-foreign import ccall "xdelta3.h xd3_avail_input" xd3_avail_input :: Ptr Xd3Stream -> Ptr a -> Usize_t -> IO ()
+-- -- declared static
+-- foreign import ccall "xdelta3.h xd3_avail_input" xd3_avail_input :: Ptr Xd3Stream -> Ptr a -> Usize_t -> IO ()
 
 avail_input :: PrimMonad m => Stream m -> Ptr a -> Usize_t -> m ()
-avail_input stream p sz =
-    unsafeIOToPrim $ xd3_avail_input (ptr $ mutableByteArrayContents $ streamArray stream) p sz
+avail_input stream p sz = do
+    writeAtByte (streamArray stream) #{offset xd3_stream, next_in} p
+    writeAtByte (streamArray stream) #{offset xd3_stream, avail_in} sz
 
 -- | This acknowledges receipt of output data, must be called after any
 -- XD3_OUTPUT return.
-foreign import ccall "xdelta3.h xd3_consume_output" xd3_consume_output :: Ptr Xd3Stream -> IO ()
+-- -- declared static
+-- foreign import ccall "xdelta3.h xd3_consume_output" xd3_consume_output :: Ptr Xd3Stream -> IO ()
 
-nextOut :: PrimMonad m => Stream m -> ((Ptr Word8, Int) -> m a) -> m a
+nextOut :: PrimMonad m => Stream m -> ((Ptr Word8, Usize_t) -> m a) -> m a
 nextOut stream action = do
     buf <- (,)
         <$> readAtByte (streamArray stream) #{offset xd3_stream, next_out}
         <*> readAtByte (streamArray stream) #{offset xd3_stream, avail_out}
     a <- action buf
-    unsafeIOToPrim $ xd3_consume_output (ptr $ mutableByteArrayContents $ streamArray stream)
+    -- unsafeIOToPrim $ xd3_consume_output (ptr $ mutableByteArrayContents $ streamArray stream)
+    writeAtByte (streamArray stream) #{offset xd3_stream, avail_out} (0 :: Usize_t)
     return a
 
 
@@ -236,14 +244,17 @@ data CurrentBlock = CurrentBlock
     , blkPtr  :: !(Ptr Word8) -- ^ current block array
     }
 
-foreign import ccall "xdelta3.h xd3_errstring" xd3_errstring :: Ptr Xd3Stream -> IO CString
+-- -- declared static
+-- foreign import ccall "xdelta3.h xd3_errstring" xd3_errstring :: Ptr Xd3Stream -> IO CString
 
 -- | Gives some extra information about the latest library error, if any
 -- is known.
 errorString :: PrimMonad m => Stream m -> m String
-errorString stream = unsafeIOToPrim $ do
-    cstring <- xd3_errstring (ptr $ mutableByteArrayContents $ streamArray stream)
-    peekCString cstring
+errorString stream = do
+    cstring <- readAtByte (streamArray stream) #offset xd3_stream, msg
+    if cstring /= nullPtr
+        then unsafeIOToPrim $ peekCString cstring -- TODO: avoid unsafeIOToPrim
+        else return ""
 
 pokeCurrentBlock :: PrimMonad m => Stream m -> CurrentBlock -> m ()
 pokeCurrentBlock stream (CurrentBlock no sz ptr) = do
@@ -279,14 +290,18 @@ xdelta x xxcode_input ds = do
             case ret of
                 XD3_INPUT -> if (not eof) then go withBlk ds else return mempty
                 XD3_OUTPUT -> do
-                    m' <- nextOut stream (uncurry $ xOutput x)
-                    ms <- xInterleave x $ go2 withBlk eof ds
-                    return $ m' <> ms
+                    m' <- nextOut stream (\(p,len) -> xOutput x p (fromIntegral len))
+                    ms <- xInterleave x $ undefined -- go2 withBlk eof ds
+                    return $ trace "chunk" m' <> ms
+                             -- XXX: This output is to test for laziness.
                 XD3_GETSRCBLK -> do
                     Just n <- requestedBlockNumber stream
                     let blk = xGetSource x n
                         withBlk' act = withByteString blk $ \p len -> do
                                     pokeCurrentBlock stream $ CurrentBlock n len p
+                                    when (len < xBlockSize x) $ do
+                                        Just src <- readMutVar $ streamSource stream
+                                        writeAtByte src #{offset xd3_source, eof_known} (1 :: #{type int})
                                     act
                     go2 withBlk' eof ds
                 XD3_GOTHEADER -> go2 withBlk eof ds -- No
@@ -314,29 +329,55 @@ encode_input stream =
     unsafeIOToPrim $ xd3_encode_input (ptr $ mutableByteArrayContents $ streamArray stream)
 
 newtype XDelta = XDelta L.ByteString
+ deriving Show
 
 chunksOf :: Usize_t -> L.ByteString -> [B.ByteString]
 chunksOf len bs | L.null bs = []
                 | otherwise = let (b,bs') = L.splitAt (fromIntegral len) bs
                               in L.toStrict b : chunksOf len bs'
 
-computeDiff :: Config -> L.ByteString -> L.ByteString -> XDelta
-computeDiff cfg source patched = XDelta $ xdeltaPure cfg source patched
+computeDiff :: Config -> L.ByteString -> L.ByteString -> XDeltaFailable XDelta
+computeDiff cfg source patched = fmap XDelta $ xdeltaPure encode_input cfg source patched
 
-applyPatch :: Config -> L.ByteString -> XDelta -> L.ByteString
-applyPatch cfg source (XDelta delta) = xdeltaPure cfg source delta
+applyPatch :: Config -> L.ByteString -> XDelta -> XDeltaFailable L.ByteString
+applyPatch cfg source (XDelta delta) = xdeltaPure decode_input cfg source delta
 
-xdeltaPure :: Config -> L.ByteString -> L.ByteString -> L.ByteString
-xdeltaPure cfg source delta =
-    let smap = IntMap.fromList $ zip [0..] (chunksOf 4096 source)
-        x :: XDeltaMethods (ST s) L.ByteString
+data XDeltaFailable x = XError ErrorCode String
+                      | XSuccess x
+    deriving (Show,Functor)
+
+instance Monoid x => Monoid (XDeltaFailable x) where
+    mempty = XSuccess mempty
+    mappend (XSuccess x) (XSuccess y) = XSuccess $ mappend x y
+    mappend x@XError{} _ = x
+    mappend _ y@XError{} = y
+
+xdeltaPure :: (forall s. Stream (ST s) -> ST s ErrorCode) -> Config -> L.ByteString -> L.ByteString -> XDeltaFailable L.ByteString
+xdeltaPure codec cfg source delta =
+    let smap = IntMap.fromList $ zip [0..] (chunksOf 16 source)
+        x :: XDeltaMethods (ST s) (XDeltaFailable L.ByteString)
         x = XDeltaMethods
                 { xConfig    = cfg
-                , xGetSource = (smap IntMap.!) . fromIntegral -- :: Xoff_t -> B.ByteString
-                , xOutput    = \ptr len -> unsafeIOToST $ L.fromStrict <$> B.packCStringLen (castPtr ptr,len)
-                , xOnError   = \e s -> return L.empty -- :: ErrorCode -> String -> m u
-                , xBlockSize = 4096 -- :: Usize_t
-                , xInterleave = id -- :: forall a. m a -> m a
+                , xGetSource = \i -> case IntMap.lookup (fromIntegral i) smap of
+                                    Nothing -> B.empty
+                                    Just bs -> bs
+                , xOutput    = \ptr len -> unsafeIOToST $ XSuccess . L.fromStrict <$> B.packCStringLen (castPtr ptr,len)
+                , xOnError   = \e s -> return (XError e s) -- :: ErrorCode -> String -> m u
+                , xBlockSize = 16 -- 4096 -- :: Usize_t
+                , xInterleave = unsafeInterleaveST -- :: forall a. m a -> m a
+                -- XXX: Why isn't unsafeInterleaveST making it lazy?
                 }
-        ds = L.toChunks delta
-    in runST $ xdelta x decode_input ds
+        ds = chunksOf 16 delta -- L.toChunks delta
+    in runST $ xdelta x codec ds
+
+defaultConfig :: Config
+defaultConfig = Config
+  { winsize   = 4096
+  , sprevsz   = 0
+  , iopt_size = 0
+  , flags     = mempty
+  , sec_data  = CompressorConfig 0 0 0
+  , sec_inst  = CompressorConfig 0 0 0
+  , sec_addr  = CompressorConfig 0 0 0
+  , smatch_cfg = Right SMATCH_DEFAULT
+  }