1 files changed, 223 insertions, 0 deletions

diff --git a/haskell/Data/XDelta.hsc b/haskell/Data/XDelta.hsc
new file mode 100644
index 0000000..11a8579
--- /dev/null
+++ b/haskell/Data/XDelta.hsc
@@ -0,0 +1,223 @@
+{-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE PatternSynonyms            #-}
+{-# LANGUAGE NondecreasingIndentation   #-}
+module Data.XDelta where
+
+import Control.Monad
+import Control.Monad.Primitive
+import Control.Monad.ST
+import Control.Monad.ST.Unsafe
+import Data.BA
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Unsafe as B
+import qualified Data.ByteString.Internal as B
+import Data.Coerce
+import Data.Primitive.Addr
+import Data.Primitive.ByteArray
+import Data.STRef
+import qualified Data.Text as T
+import Data.Text.Encoding
+import Data.Word
+import Foreign.C.Types
+import Foreign.ForeignPtr (withForeignPtr)
+import Foreign.Ptr
+import Foreign.Concurrent
+import Foreign.ForeignPtr (ForeignPtr)
+import GHC.Exts
+
+import XDelta.Types
+
+#ifndef SIZEOF_SIZE_T
+#define SIZEOF_SIZE_T __SIZEOF_SIZE_T__
+#define SIZEOF_UNSIGNED_INT __SIZEOF_INT__
+#define SIZEOF_UNSIGNED_LONG __SIZEOF_LONG__
+#define SIZEOF_UNSIGNED_LONG_LONG __SIZEOF_LONG_LONG__
+#define static_assert(...)
+#endif
+#include <xdelta3.h>
+
+data Stream s = Stream
+    { streamArray :: MutableByteArray (PrimState (ST s))
+    , streamPtr :: ForeignPtr Xd3Stream
+    , streamSource :: STRef s (Maybe (MutableByteArray (PrimState (ST s))))
+    }
+
+foreign import ccall "xdelta3.h xd3_config_stream" xd3_config_stream :: Ptr Xd3Stream -> Ptr Config -> IO ErrorCode
+
+foreign import ccall "xdelta3.h xd3_free_stream" xd3_free_stream :: Ptr Xd3Stream -> IO ()
+
+foreign import ccall "xdelta3.h xd3_abort_stream" xd3_abort_stream :: Ptr Xd3Stream -> IO ()
+
+foreign import ccall "xdelta3.h xd3_close_stream" xd3_close_stream :: Ptr Xd3Stream -> IO ErrorCode
+
+
+writeCompressorConfig c o sec = do
+    writeAtByte c (o + #{offset xd3_sec_cfg,ngroups}) (ngroups sec)
+    writeAtByte c (o + #{offset xd3_sec_cfg,sector_size}) (sector_size sec)
+    writeAtByte c (o + #{offset xd3_sec_cfg,inefficient}) (inefficient sec)
+
+writeMatcher c o sm = do
+    -- handled elsewhere: const char *name; <- smName :: String
+    writeAtByte c (o + #{offset xd3_smatcher, string_match }) (smStringMatch sm)
+    writeAtByte c (o + #{offset xd3_smatcher, large_look   }) (smLargeLook sm)
+    writeAtByte c (o + #{offset xd3_smatcher, large_step   }) (smLargeStep sm)
+    writeAtByte c (o + #{offset xd3_smatcher, small_look   }) (smSmallLook sm)
+    writeAtByte c (o + #{offset xd3_smatcher, small_chain  }) (smSmallChain sm)
+    writeAtByte c (o + #{offset xd3_smatcher, small_lchain }) (smSmallLchain sm)
+    writeAtByte c (o + #{offset xd3_smatcher, max_lazy     }) (smMaxLazy sm)
+    writeAtByte c (o + #{offset xd3_smatcher, long_enough  }) (smLongEnough sm)
+
+ptr (Addr a) = Ptr a
+adr (Ptr a) = Addr a
+
+-- The xd3_config structure is used to initialize a stream - all data
+-- is copied into stream so config may be a temporary variable.  See
+-- the [documentation] or comments on the xd3_config structure.
+config_stream :: Config -> ST s (Either ErrorCode (Stream s))
+config_stream cfg = do
+    let (len,n) = case smatch_cfg cfg of
+            Left  m -> let n = encodeUtf8 $ T.pack $ smName m
+                       in ( #{const sizeof(xd3_stream)} + B.length n + 1
+                          , n )
+            Right _ -> ( #{const sizeof(xd3_stream)}, B.empty )
+    s <- newPinnedByteArray len
+    let sptr = ptr (mutableByteArrayContents s) :: Ptr Xd3Stream
+    fillByteArray s 0 #{const sizeof(xd3_stream)} 0
+    nptr <- case smatch_cfg cfg of
+        Right _ -> writeStringAt s #{const sizeof(xd3_stream)} n
+        Left _ -> return nullPtr
+    c <- do
+        c <- newPinnedByteArray #const sizeof(xd3_config)
+        fillByteArray c 0 #{const sizeof(xd3_config)} 0
+        writeAtByte c #{offset xd3_config, winsize} (winsize cfg)
+        writeAtByte c #{offset xd3_config, sprevsz} (sprevsz cfg)
+        writeAtByte c #{offset xd3_config, iopt_size} (iopt_size cfg)
+        writeAtByte c #{offset xd3_config, flags} (coerce (flags cfg) :: Word32)
+        writeCompressorConfig c #{offset xd3_config, sec_data} (sec_data cfg)
+        writeCompressorConfig c #{offset xd3_config, sec_inst} (sec_inst cfg)
+        writeCompressorConfig c #{offset xd3_config, sec_addr} (sec_addr cfg)
+        let msel :: #type xd3_smatch_cfg
+            msel = either (const #{const XD3_SMATCH_SOFT})
+                          (fromIntegral . fromEnum)
+                          (smatch_cfg cfg)
+        writeAtByte c #{offset xd3_config, smatch_cfg} msel
+        case smatch_cfg cfg of
+            Right _      -> return ()
+            Left matcher -> do
+                let o = #offset xd3_config,smatcher_soft
+                writeAtByte c (o + #{offset xd3_smatcher, name}) nptr
+                writeMatcher c o matcher
+        unsafeFreezeByteArray c
+    let cptr = ptr (byteArrayContents c) :: Ptr Config
+    srcvar <- newSTRef Nothing
+    stream <- unsafeIOToST $ do
+        let finalize = do
+                -- freeHaskellFunPtr: aloc,free,getblk
+                xd3_abort_stream sptr
+                xd3_close_stream sptr
+                xd3_free_stream sptr
+        fp <- newForeignPtr sptr finalize
+        return Stream
+            { streamArray  = s
+            , streamPtr    = fp
+            , streamSource = srcvar
+            }
+    unsafeIOToST (xd3_config_stream sptr cptr) >>= \case
+        XD3_SUCCESS -> return $ c `seq` Right stream
+        ecode       -> return $ Left ecode
+
+writeStringAt src o bsname = do
+            (p,cnt) <- unsafeIOToST $ B.unsafeUseAsCStringLen bsname return
+            let nptr = ptr (mutableByteArrayContents src) `plusPtr` o
+            copyAddr (adr nptr) (adr p) cnt
+            writeOffAddr (adr nptr) cnt (0 :: Word8)
+            return nptr
+
+data Xd3Source
+
+foreign import ccall "xdelta3.h xd3_set_source" xd3_set_source :: Ptr Xd3Stream -> Ptr Xd3Source -> IO ErrorCode
+
+set_source :: Stream s -> String  -- ^ name for debug/print purposes.
+                       -> Usize_t -- ^ block size
+                       -> Xoff_t  -- ^ maximum visible buffer
+                       -> ST s ()
+set_source stream nm blksz maxwinsz = do
+    let bsname = encodeUtf8 $ T.pack nm
+    src <- newPinnedByteArray $ 1 + B.length bsname + #{const sizeof(xd3_source)}
+    nptr <- writeStringAt src #{const sizeof(xd3_source)} bsname
+    writeAtByte src #{offset xd3_source, blksize    } blksz
+    writeAtByte src #{offset xd3_source, name       } nptr
+    writeAtByte src #{offset xd3_source, max_winsize} maxwinsz
+    writeAtByte src #{offset xd3_source, curblkno   } (maxBound :: Xoff_t)
+    {-
+    writeAtByte (streamArray stream)
+                #{offset xd3_stream, getblk}
+                nullPtr -- xdelta3.h documents this as an internal field.
+    -}
+    let strm = ptr (mutableByteArrayContents $ streamArray stream)
+        srcptr = ptr (mutableByteArrayContents src)
+    unsafeIOToST (xd3_set_source strm srcptr)
+    writeSTRef (streamSource stream) (Just src)
+
+data XDeltaMethods m = XDeltaMethods
+    { xConfig    :: Config
+    , xGetSource :: Xoff_t -> B.ByteString
+    , xOutput    :: Ptr Word8 -> Int -> IO m
+    , xOnError   :: ErrorCode -> String -> IO m
+    , xBlockSize :: Usize_t
+    }
+
+-- | Checks for legal flag changes.
+foreign import ccall "xdelta3.h xd3_set_flags" xd3_set_flags :: Ptr Xd3Stream -> Flags -> IO ()
+
+setFlush :: Stream s -> Bool -> ST s ()
+setFlush stream wantFlush = return () -- todo
+
+setSkipWindow :: Stream s -> Bool -> ST s ()
+setSkipWindow stream wantSkipWin = return () -- todo
+
+{-
+xdelta :: Monoid m => XDeltaMethods m -> (Stream s -> IO ErrorCode) -> [B.ByteString] -> ST s m
+xdelta x xxcode_input ds = do
+    mstream <- config_stream (xConfig x)
+    forM_ mstream $ \stream -> do
+    set_source stream "xdelta" (xBlockSize x) (xBlockSize x)
+    let go withBlk (d:ds) = do
+            let (fp,off,len) = B.toForeignPtr d
+            withForeignPtr fp $ \indata0 -> do
+                let indata = indata0 `plusPtr` off
+                    eof = null ds
+                when eof $ xd3_set_flags (ptr $ mutableByteArrayContents $ streamArray stream) XD3_FLUSH
+                avail_input stream indata (fromIntegral len)
+                go2 withBlk eof ds
+        go2 withBlk eof ds = do
+            ret <- withBlk $ xxcode_input stream
+            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 <- unsafeInterleaveIO $ go2 withBlk eof ds
+                    return $ m' <> ms
+                XD3_GETSRCBLK -> do
+                    n <- requestedBlockNumber stream
+                    let blk = xGetSource x n
+                        withBlk' act = let (fp,off,len) = B.toForeignPtr blk
+                                       in withForeignPtr fp $ \p -> do
+                                           pokeCurrentBlock stream $ CurrentBlock n (fromIntegral len) (plusPtr p off)
+                                           act
+                    go2 withBlk' eof ds
+                XD3_GOTHEADER -> go2 withBlk eof ds -- No
+                XD3_WINSTART  -> go2 withBlk eof ds --  action
+                XD3_WINFINISH -> go2 withBlk eof ds --   neccessary
+                            -- -- These are set for each XD3_WINFINISH return.
+                            -- xd3_encoder_used_source :: Ptr Stream -> IO Bool
+                            -- xd3_encoder_srcbase :: Ptr Stream -> IO Xoff_t
+                            -- xd3_encoder_srclen :: Ptr Stream -> IO Usize_t
+                e -> do
+                    s <- errorString stream
+                    xOnError x e s
+    go id ds
+-}