withByteString (wrapper on withForeignPtr)

1 files changed, 32 insertions, 17 deletions

diff --git a/haskell/Data/XDelta.hsc b/haskell/Data/XDelta.hsc
index 113959b..d276a8d 100644
--- a/haskell/Data/XDelta.hsc
+++ b/haskell/Data/XDelta.hsc
@@ -59,11 +59,15 @@ foreign import ccall "xdelta3.h xd3_abort_stream" xd3_abort_stream :: Ptr Xd3Str
 foreign import ccall "xdelta3.h xd3_close_stream" xd3_close_stream :: Ptr Xd3Stream -> IO ErrorCode
 
 
+writeCompressorConfig :: PrimMonad m =>
+                               MutableByteArray (PrimState m) -> Int -> CompressorConfig -> m ()
 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 :: PrimMonad m =>
+                      MutableByteArray (PrimState m) -> Int -> StringMatcher -> m ()
 writeMatcher c o sm = do
     -- handled elsewhere: const char *name; <- smName :: String
     writeAtByte c (o + #{offset xd3_smatcher, string_match }) (smStringMatch sm)
@@ -75,7 +79,10 @@ writeMatcher c o sm = do
     writeAtByte c (o + #{offset xd3_smatcher, max_lazy     }) (smMaxLazy sm)
     writeAtByte c (o + #{offset xd3_smatcher, long_enough  }) (smLongEnough sm)
 
+ptr :: Addr -> Ptr a
 ptr (Addr a) = Ptr a
+
+adr :: Ptr a -> Addr
 adr (Ptr a) = Addr a
 
 -- The xd3_config structure is used to initialize a stream - all data
@@ -134,12 +141,13 @@ config_stream cfg = do
         XD3_SUCCESS -> return $ c `seq` Right stream
         ecode       -> return $ Left ecode
 
+writeStringAt :: PrimMonad m => MutableByteArray s -> Int -> B.ByteString -> m (Ptr a)
 writeStringAt src o bsname = do
-            (p,cnt) <- unsafeIOToPrim $ 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
+    (p,cnt) <- unsafeIOToPrim $ 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
 
@@ -222,8 +230,9 @@ foreign import ccall "xdelta3.h xd3_errstring" xd3_errstring :: Ptr Xd3Stream ->
 
 -- | Gives some extra information about the latest library error, if any
 -- is known.
-errorString stream = unsafeIOToPrim $ withForeignPtr (streamPtr stream) $ \stream -> do
-    cstring <- xd3_errstring stream
+errorString :: PrimMonad m => Stream m -> m String
+errorString stream = unsafeIOToPrim $ do
+    cstring <- xd3_errstring (ptr $ mutableByteArrayContents $ streamArray stream)
     peekCString cstring
 
 pokeCurrentBlock :: PrimMonad m => Stream m -> CurrentBlock -> m ()
@@ -235,20 +244,27 @@ pokeCurrentBlock stream (CurrentBlock no sz ptr) = do
         writeAtByte src #{offset xd3_source, curblk}   ptr
 
 
+withByteString :: PrimBase m => B.ByteString -> (Ptr b -> Usize_t -> m a) -> m a
+withByteString d act =
+    let (fp,off,len) = B.toForeignPtr d
+    in unsafeIOToPrim $ withForeignPtr fp $ \ptr -> unsafePrimToIO $ do
+        act (ptr `plusPtr` off) (fromIntegral len)
+
 xdelta :: (PrimBase m, Monoid u) => XDeltaMethods m u -> (Stream m -> IO ErrorCode) -> [B.ByteString]
-    -> m (Either ErrorCode u)
+    -> m u
 xdelta x xxcode_input ds = do
     mstream <- config_stream (xConfig x)
-    forM mstream $ \stream -> do
+    either (\e _ -> xOnError x e "config_stream failed")
+           (flip ($))
+           mstream $ \stream -> do
     set_source stream "xdelta" (xBlockSize x) (xBlockSize x)
     let go withBlk (d:ds) = do
             let (fp,off,len) = B.toForeignPtr d
                 eof = null ds
             when eof $ setFlush stream True
-            unsafeIOToPrim $ withForeignPtr fp $ \indata0 -> do
-                let indata = indata0 `plusPtr` off
-                avail_input stream indata (fromIntegral len)
-                unsafePrimToIO $ go2 withBlk eof ds
+            withByteString d $ \indata len -> do
+                avail_input stream indata len
+                go2 withBlk eof ds
         go2 withBlk eof ds = do
             ret <- withBlk $ unsafeIOToPrim $ xxcode_input stream
             case ret of
@@ -260,10 +276,9 @@ xdelta x xxcode_input ds = do
                 XD3_GETSRCBLK -> do
                     Just n <- requestedBlockNumber stream
                     let blk = xGetSource x n
-                        withBlk' act = let (fp,off,len) = B.toForeignPtr blk
-                                       in unsafeIOToPrim $ withForeignPtr fp $ \p -> unsafePrimToIO $ do
-                                        pokeCurrentBlock stream $ CurrentBlock n (fromIntegral len) (plusPtr p off)
-                                        act
+                        withBlk' act = withByteString blk $ \p len -> do
+                                    pokeCurrentBlock stream $ CurrentBlock n len p
+                                    act
                     go2 withBlk' eof ds
                 XD3_GOTHEADER -> go2 withBlk eof ds -- No
                 XD3_WINSTART  -> go2 withBlk eof ds --  action