diff options
Diffstat (limited to 'haskell/Data')
-rw-r--r-- | haskell/Data/VCDIFF.hs (renamed from haskell/Data/VCDIFF.hsc) | 135 | ||||
-rw-r--r-- | haskell/Data/VCDIFF/XDelta.hsc | 202 |
2 files changed, 213 insertions, 124 deletions
diff --git a/haskell/Data/VCDIFF.hsc b/haskell/Data/VCDIFF.hs index 804b119..a776052 100644 --- a/haskell/Data/VCDIFF.hsc +++ b/haskell/Data/VCDIFF.hs | |||
@@ -1,4 +1,3 @@ | |||
1 | {-# OPTIONS_GHC -Wno-partial-type-signatures #-} | ||
2 | {-# LANGUAGE BangPatterns #-} | 1 | {-# LANGUAGE BangPatterns #-} |
3 | {-# LANGUAGE DataKinds #-} | 2 | {-# LANGUAGE DataKinds #-} |
4 | {-# LANGUAGE DeriveFunctor #-} | 3 | {-# LANGUAGE DeriveFunctor #-} |
@@ -8,7 +7,6 @@ | |||
8 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} |
9 | {-# LANGUAGE LambdaCase #-} | 8 | {-# LANGUAGE LambdaCase #-} |
10 | {-# LANGUAGE NondecreasingIndentation #-} | 9 | {-# LANGUAGE NondecreasingIndentation #-} |
11 | {-# LANGUAGE PartialTypeSignatures #-} | ||
12 | {-# LANGUAGE PatternSynonyms #-} | 10 | {-# LANGUAGE PatternSynonyms #-} |
13 | {-# LANGUAGE RankNTypes #-} | 11 | {-# LANGUAGE RankNTypes #-} |
14 | {-# LANGUAGE TypeFamilies #-} | 12 | {-# LANGUAGE TypeFamilies #-} |
@@ -49,19 +47,8 @@ import GHC.TypeLits | |||
49 | import Data.VCDIFF.Types | 47 | import Data.VCDIFF.Types |
50 | import Data.VCDIFF.XDelta | 48 | import Data.VCDIFF.XDelta |
51 | 49 | ||
52 | #ifndef SIZEOF_SIZE_T | ||
53 | #define SIZEOF_SIZE_T __SIZEOF_SIZE_T__ | ||
54 | #define SIZEOF_UNSIGNED_INT __SIZEOF_INT__ | ||
55 | #define SIZEOF_UNSIGNED_LONG __SIZEOF_LONG__ | ||
56 | #define SIZEOF_UNSIGNED_LONG_LONG __SIZEOF_LONG_LONG__ | ||
57 | #define static_assert(...) | ||
58 | #endif | ||
59 | #include <xdelta3.h> | ||
60 | |||
61 | #include "offset.h" | ||
62 | |||
63 | data Stream m = Stream | 50 | data Stream m = Stream |
64 | { streamArray :: MutableByteArray (PrimState m) | 51 | { streamArray :: StreamArray m |
65 | , streamPtr :: ForeignPtr Xd3Stream -- ^ HACK: this is only used to attach a finalizer | 52 | , streamPtr :: ForeignPtr Xd3Stream -- ^ HACK: this is only used to attach a finalizer |
66 | -- to 'streamArray'. Don't use this pointer. | 53 | -- to 'streamArray'. Don't use this pointer. |
67 | -- This would be unnecessary if I could create a | 54 | -- This would be unnecessary if I could create a |
@@ -69,73 +56,16 @@ data Stream m = Stream | |||
69 | , streamSource :: MutVar (PrimState m) (Maybe (Source m)) | 56 | , streamSource :: MutVar (PrimState m) (Maybe (Source m)) |
70 | } | 57 | } |
71 | 58 | ||
72 | foreign import ccall "xdelta3.h xd3_config_stream" xd3_config_stream :: Ptr Xd3Stream -> Ptr Config -> IO ErrorCode | ||
73 | |||
74 | foreign import ccall "xdelta3.h xd3_free_stream" xd3_free_stream :: Ptr Xd3Stream -> IO () | ||
75 | |||
76 | foreign import ccall "xdelta3.h xd3_abort_stream" xd3_abort_stream :: Ptr Xd3Stream -> IO () | ||
77 | |||
78 | foreign import ccall "xdelta3.h xd3_close_stream" xd3_close_stream :: Ptr Xd3Stream -> IO ErrorCode | ||
79 | |||
80 | |||
81 | |||
82 | writeCompressorConfig :: (PrimMonad m, _) => MutableByteArray (PrimState m) -> Offset j -> CompressorConfig -> m () | ||
83 | writeCompressorConfig c o sec = do | ||
84 | writeAtByte c (o +. #{off xd3_sec_cfg,ngroups}) (ngroups sec) | ||
85 | writeAtByte c (o +. #{off xd3_sec_cfg,sector_size}) (sector_size sec) | ||
86 | writeAtByte c (o +. #{off xd3_sec_cfg,inefficient}) (inefficient sec) | ||
87 | |||
88 | writeMatcher :: (PrimMonad m, _) => MutableByteArray (PrimState m) -> Offset j -> StringMatcher -> m () | ||
89 | writeMatcher c o sm = do | ||
90 | -- handled elsewhere: const char *name; <- smName :: String | ||
91 | writeAtByte c (o +. #{off xd3_smatcher, string_match }) (smStringMatch sm) | ||
92 | writeAtByte c (o +. #{off xd3_smatcher, large_look }) (smLargeLook sm) | ||
93 | writeAtByte c (o +. #{off xd3_smatcher, large_step }) (smLargeStep sm) | ||
94 | writeAtByte c (o +. #{off xd3_smatcher, small_look }) (smSmallLook sm) | ||
95 | writeAtByte c (o +. #{off xd3_smatcher, small_chain }) (smSmallChain sm) | ||
96 | writeAtByte c (o +. #{off xd3_smatcher, small_lchain }) (smSmallLchain sm) | ||
97 | writeAtByte c (o +. #{off xd3_smatcher, max_lazy }) (smMaxLazy sm) | ||
98 | writeAtByte c (o +. #{off xd3_smatcher, long_enough }) (smLongEnough sm) | ||
99 | 59 | ||
100 | -- The xd3_config structure is used to initialize a stream - all data | 60 | -- The xd3_config structure is used to initialize a stream - all data |
101 | -- is copied into stream so config may be a temporary variable. See | 61 | -- is copied into stream so config may be a temporary variable. See |
102 | -- the [documentation] or comments on the xd3_config structure. | 62 | -- the [documentation] or comments on the xd3_config structure. |
103 | config_stream :: PrimMonad m => Config -> m (Either ErrorCode (Stream m)) | 63 | config_stream :: PrimMonad m => Config -> m (Either ErrorCode (Stream m)) |
104 | config_stream cfg = do | 64 | config_stream cfg = do |
105 | let (len,n) = case smatch_cfg cfg of | 65 | (s,nptr) <- newStreamArray (either (Just . smName) (const Nothing) (smatch_cfg cfg)) |
106 | Left m -> let n = encodeUtf8 $ T.pack $ smName m | 66 | c <- packConfig nptr cfg |
107 | in ( #{const sizeof(xd3_stream)} + B.length n + 1 | ||
108 | , n ) | ||
109 | Right _ -> ( #{const sizeof(xd3_stream)}, B.empty ) | ||
110 | s <- newPinnedByteArray len | ||
111 | let sptr = ptr (mutableByteArrayContents s) :: Ptr Xd3Stream | ||
112 | fillByteArray s 0 #{const sizeof(xd3_stream)} 0 | ||
113 | nptr <- case smatch_cfg cfg of | ||
114 | Right _ -> writeStringAt s #{const sizeof(xd3_stream)} n | ||
115 | Left _ -> return nullPtr | ||
116 | c <- do | ||
117 | c <- newPinnedByteArray #const sizeof(xd3_config) | ||
118 | fillByteArray c 0 #{const sizeof(xd3_config)} 0 | ||
119 | writeAtByte c #{off xd3_config, winsize} (winsize cfg) | ||
120 | writeAtByte c #{off xd3_config, sprevsz} (sprevsz cfg) | ||
121 | writeAtByte c #{off xd3_config, iopt_size} (iopt_size cfg) | ||
122 | writeAtByte c #{off xd3_config, flags} (coerce (flags cfg) :: Word32) | ||
123 | writeCompressorConfig c #{off xd3_config, sec_data} (sec_data cfg) | ||
124 | writeCompressorConfig c #{off xd3_config, sec_inst} (sec_inst cfg) | ||
125 | writeCompressorConfig c #{off xd3_config, sec_addr} (sec_addr cfg) | ||
126 | let msel :: #type xd3_smatch_cfg | ||
127 | msel = either (const #{const XD3_SMATCH_SOFT}) | ||
128 | (fromIntegral . fromEnum) | ||
129 | (smatch_cfg cfg) | ||
130 | writeAtByte c (#{off xd3_config, smatch_cfg}) msel | ||
131 | case smatch_cfg cfg of | ||
132 | Right _ -> return () | ||
133 | Left matcher -> do | ||
134 | let o = offset :: Offset #offset xd3_config,smatcher_soft | ||
135 | writeAtByte c (o +. (#{off xd3_smatcher, name})) nptr | ||
136 | writeMatcher c o matcher | ||
137 | unsafeFreezeByteArray c | ||
138 | let cptr = ptr (byteArrayContents c) :: Ptr Config | 67 | let cptr = ptr (byteArrayContents c) :: Ptr Config |
68 | sptr = streamArrayPtr s | ||
139 | srcvar <- newMutVar Nothing | 69 | srcvar <- newMutVar Nothing |
140 | stream <- unsafeIOToPrim $ do | 70 | stream <- unsafeIOToPrim $ do |
141 | let finalize = do | 71 | let finalize = do |
@@ -154,8 +84,6 @@ config_stream cfg = do | |||
154 | XD3_SUCCESS -> return $ c `seq` Right stream | 84 | XD3_SUCCESS -> return $ c `seq` Right stream |
155 | ecode -> return $ Left ecode | 85 | ecode -> return $ Left ecode |
156 | 86 | ||
157 | foreign import ccall "xdelta3.h xd3_set_source" xd3_set_source :: Ptr Xd3Stream -> Ptr Xd3Source -> IO ErrorCode | ||
158 | |||
159 | 87 | ||
160 | set_source :: PrimMonad m => | 88 | set_source :: PrimMonad m => |
161 | Stream m -> String -- ^ name for debug/print purposes. | 89 | Stream m -> String -- ^ name for debug/print purposes. |
@@ -170,7 +98,7 @@ set_source stream nm blksz maxwinsz = do | |||
170 | #{offset xd3_stream, getblk} | 98 | #{offset xd3_stream, getblk} |
171 | nullPtr -- xdelta3.h documents this as an internal field. | 99 | nullPtr -- xdelta3.h documents this as an internal field. |
172 | -} | 100 | -} |
173 | let strm = ptr (mutableByteArrayContents $ streamArray stream) | 101 | let strm = streamArrayPtr $ streamArray stream |
174 | unsafeIOToPrim (xd3_set_source strm $ sourcePtr src) | 102 | unsafeIOToPrim (xd3_set_source strm $ sourcePtr src) |
175 | writeMutVar (streamSource stream) (Just src) | 103 | writeMutVar (streamSource stream) (Just src) |
176 | 104 | ||
@@ -186,43 +114,14 @@ data XDeltaMethods m u = XDeltaMethods | |||
186 | -- -- | Checks for legal flag changes. | 114 | -- -- | Checks for legal flag changes. |
187 | -- foreign import ccall "xdelta3.h xd3_set_flags" xd3_set_flags :: Ptr Xd3Stream -> Flags -> IO () | 115 | -- foreign import ccall "xdelta3.h xd3_set_flags" xd3_set_flags :: Ptr Xd3Stream -> Flags -> IO () |
188 | 116 | ||
189 | setFlag :: PrimMonad m => Flags -> Stream m -> Bool -> m () | ||
190 | setFlag b stream wantFlush = do | ||
191 | f <- readAtByte (streamArray stream) (#{off xd3_stream, flags}) | ||
192 | writeAtByte (streamArray stream) (#{off xd3_stream, flags}) | ||
193 | . (coerce :: Flags -> Word32) | ||
194 | $ if wantFlush then Flags f .|. b | ||
195 | else Flags f .&. complement b | ||
196 | |||
197 | setFlush :: PrimMonad m => Stream m -> Bool -> m () | ||
198 | setFlush = setFlag XD3_FLUSH | ||
199 | |||
200 | setSkipWindow :: PrimMonad m => Stream m -> Bool -> m () | ||
201 | setSkipWindow = setFlag XD3_SKIP_WINDOW | ||
202 | |||
203 | -- -- declared static | 117 | -- -- declared static |
204 | -- foreign import ccall "xdelta3.h xd3_avail_input" xd3_avail_input :: Ptr Xd3Stream -> Ptr a -> Usize_t -> IO () | 118 | -- foreign import ccall "xdelta3.h xd3_avail_input" xd3_avail_input :: Ptr Xd3Stream -> Ptr a -> Usize_t -> IO () |
205 | 119 | ||
206 | avail_input :: PrimMonad m => Stream m -> Ptr a -> Usize_t -> m () | ||
207 | avail_input stream p sz = do | ||
208 | writeAtByte (streamArray stream) (#{off xd3_stream, next_in}) p | ||
209 | writeAtByte (streamArray stream) (#{off xd3_stream, avail_in}) sz | ||
210 | |||
211 | -- | This acknowledges receipt of output data, must be called after any | 120 | -- | This acknowledges receipt of output data, must be called after any |
212 | -- XD3_OUTPUT return. | 121 | -- XD3_OUTPUT return. |
213 | -- -- declared static | 122 | -- -- declared static |
214 | -- foreign import ccall "xdelta3.h xd3_consume_output" xd3_consume_output :: Ptr Xd3Stream -> IO () | 123 | -- foreign import ccall "xdelta3.h xd3_consume_output" xd3_consume_output :: Ptr Xd3Stream -> IO () |
215 | 124 | ||
216 | nextOut :: PrimMonad m => Stream m -> ((Ptr Word8, Usize_t) -> m a) -> m a | ||
217 | nextOut stream action = do | ||
218 | buf <- (,) | ||
219 | <$> readAtByte (streamArray stream) (#{off xd3_stream, next_out}) | ||
220 | <*> readAtByte (streamArray stream) (#{off xd3_stream, avail_out}) | ||
221 | a <- action buf | ||
222 | -- unsafeIOToPrim $ xd3_consume_output (ptr $ mutableByteArrayContents $ streamArray stream) | ||
223 | writeAtByte (streamArray stream) (#{off xd3_stream, avail_out}) (0 :: Usize_t) | ||
224 | return a | ||
225 | |||
226 | requestedBlockNumber :: PrimMonad m => Stream m -> m (Maybe Xoff_t) | 125 | requestedBlockNumber :: PrimMonad m => Stream m -> m (Maybe Xoff_t) |
227 | requestedBlockNumber stream = do | 126 | requestedBlockNumber stream = do |
228 | msrc <- readMutVar $ streamSource stream | 127 | msrc <- readMutVar $ streamSource stream |
@@ -231,15 +130,6 @@ requestedBlockNumber stream = do | |||
231 | -- -- declared static | 130 | -- -- declared static |
232 | -- foreign import ccall "xdelta3.h xd3_errstring" xd3_errstring :: Ptr Xd3Stream -> IO CString | 131 | -- foreign import ccall "xdelta3.h xd3_errstring" xd3_errstring :: Ptr Xd3Stream -> IO CString |
233 | 132 | ||
234 | -- | Gives some extra information about the latest library error, if any | ||
235 | -- is known. | ||
236 | errorString :: PrimMonad m => Stream m -> m String | ||
237 | errorString stream = do | ||
238 | cstring <- readAtByte (streamArray stream) (#{off xd3_stream, msg}) | ||
239 | if cstring /= nullPtr | ||
240 | then unsafeIOToPrim $ peekCString cstring -- TODO: avoid unsafeIOToPrim | ||
241 | else return "" | ||
242 | |||
243 | pokeCurrentBlock :: PrimMonad m => Stream m -> CurrentBlock -> m () | 133 | pokeCurrentBlock :: PrimMonad m => Stream m -> CurrentBlock -> m () |
244 | pokeCurrentBlock stream blk = do | 134 | pokeCurrentBlock stream blk = do |
245 | msrc <- readMutVar $ streamSource stream | 135 | msrc <- readMutVar $ streamSource stream |
@@ -262,16 +152,16 @@ xdelta x xxcode_input ds = do | |||
262 | go withBlk (d:ds) = do | 152 | go withBlk (d:ds) = do |
263 | let (fp,off,len) = B.toForeignPtr d | 153 | let (fp,off,len) = B.toForeignPtr d |
264 | eof = null ds | 154 | eof = null ds |
265 | when eof $ setFlush stream True | 155 | when eof $ setFlush (streamArray stream) True |
266 | withByteString d $ \indata len -> do | 156 | withByteString d $ \indata len -> do |
267 | avail_input stream indata len | 157 | avail_input (streamArray stream) indata len |
268 | go2 withBlk eof ds | 158 | go2 withBlk eof ds |
269 | go2 withBlk eof ds = do | 159 | go2 withBlk eof ds = do |
270 | ret <- withBlk $ xxcode_input stream | 160 | ret <- withBlk $ xxcode_input stream |
271 | case ret of | 161 | case ret of |
272 | XD3_INPUT -> if (not eof) then go withBlk ds else return mempty | 162 | XD3_INPUT -> if (not eof) then go withBlk ds else return mempty |
273 | XD3_OUTPUT -> do | 163 | XD3_OUTPUT -> do |
274 | m' <- nextOut stream (\(p,len) -> xOutput x p (fromIntegral len)) | 164 | m' <- nextOut (streamArray stream) (\(p,len) -> xOutput x p (fromIntegral len)) |
275 | ms <- xInterleave x $ go2 withBlk eof ds | 165 | ms <- xInterleave x $ go2 withBlk eof ds |
276 | return $ m' <> ms | 166 | return $ m' <> ms |
277 | XD3_GETSRCBLK -> do | 167 | XD3_GETSRCBLK -> do |
@@ -292,21 +182,18 @@ xdelta x xxcode_input ds = do | |||
292 | -- xd3_encoder_srcbase :: Ptr Stream -> IO Xoff_t | 182 | -- xd3_encoder_srcbase :: Ptr Stream -> IO Xoff_t |
293 | -- xd3_encoder_srclen :: Ptr Stream -> IO Usize_t | 183 | -- xd3_encoder_srclen :: Ptr Stream -> IO Usize_t |
294 | e -> do | 184 | e -> do |
295 | s <- errorString stream | 185 | s <- errorString (streamArray stream) |
296 | xOnError x e s | 186 | xOnError x e s |
297 | xInterleave x $ go id ds | 187 | xInterleave x $ go id ds |
298 | 188 | ||
299 | 189 | ||
300 | foreign import ccall "xdelta3.h xd3_decode_input" xd3_decode_input :: Ptr Xd3Stream -> IO ErrorCode | ||
301 | foreign import ccall "xdelta3.h xd3_encode_input" xd3_encode_input :: Ptr Xd3Stream -> IO ErrorCode | ||
302 | |||
303 | decode_input :: PrimMonad m => Stream m -> m ErrorCode | 190 | decode_input :: PrimMonad m => Stream m -> m ErrorCode |
304 | decode_input stream = | 191 | decode_input stream = |
305 | unsafeIOToPrim $ xd3_decode_input (ptr $ mutableByteArrayContents $ streamArray stream) | 192 | unsafeIOToPrim $ xd3_decode_input (streamArrayPtr $ streamArray stream) |
306 | 193 | ||
307 | encode_input :: PrimMonad m => Stream m -> m ErrorCode | 194 | encode_input :: PrimMonad m => Stream m -> m ErrorCode |
308 | encode_input stream = | 195 | encode_input stream = |
309 | unsafeIOToPrim $ xd3_encode_input (ptr $ mutableByteArrayContents $ streamArray stream) | 196 | unsafeIOToPrim $ xd3_encode_input (streamArrayPtr $ streamArray stream) |
310 | 197 | ||
311 | -- RFC 3284 | 198 | -- RFC 3284 |
312 | newtype VCDIFF = VCDIFF L.ByteString | 199 | newtype VCDIFF = VCDIFF L.ByteString |
diff --git a/haskell/Data/VCDIFF/XDelta.hsc b/haskell/Data/VCDIFF/XDelta.hsc new file mode 100644 index 0000000..6e32494 --- /dev/null +++ b/haskell/Data/VCDIFF/XDelta.hsc | |||
@@ -0,0 +1,202 @@ | |||
1 | {-# OPTIONS_GHC -Wno-partial-type-signatures #-} | ||
2 | {-# LANGUAGE DataKinds #-} | ||
3 | {-# LANGUAGE PartialTypeSignatures #-} | ||
4 | {-# LANGUAGE TypeFamilies #-} | ||
5 | module Data.VCDIFF.XDelta where | ||
6 | |||
7 | import Control.Monad | ||
8 | import Control.Monad.Primitive | ||
9 | import Data.Bits | ||
10 | import qualified Data.ByteString as B | ||
11 | import Data.Coerce | ||
12 | import Data.Int | ||
13 | import Data.Primitive.ByteArray | ||
14 | import Data.Primitive.ByteArray.Util | ||
15 | import qualified Data.Text as T | ||
16 | import Data.Text.Encoding | ||
17 | import Data.VCDIFF.Types | ||
18 | import Data.Word | ||
19 | import Foreign.C.Types | ||
20 | import Foreign.C.String | ||
21 | import Foreign.Ptr | ||
22 | |||
23 | #ifndef SIZEOF_SIZE_T | ||
24 | #define SIZEOF_SIZE_T __SIZEOF_SIZE_T__ | ||
25 | #define SIZEOF_UNSIGNED_INT __SIZEOF_INT__ | ||
26 | #define SIZEOF_UNSIGNED_LONG __SIZEOF_LONG__ | ||
27 | #define SIZEOF_UNSIGNED_LONG_LONG __SIZEOF_LONG_LONG__ | ||
28 | #define static_assert(...) | ||
29 | #endif | ||
30 | #include <xdelta3.h> | ||
31 | |||
32 | #include "offset.h" | ||
33 | |||
34 | type instance SizeOf Usize_t = #const sizeof(usize_t) | ||
35 | type instance SizeOf (FunPtr a) = #const sizeof(void(*)()) | ||
36 | type instance SizeOf (Ptr a) = #const sizeof(void*) | ||
37 | type instance SizeOf #{type int} = #const sizeof(int) | ||
38 | type instance SizeOf #{type unsigned int} = #const sizeof(unsigned int) | ||
39 | |||
40 | |||
41 | data Xd3Source | ||
42 | |||
43 | newtype Source m = Source (MutableByteArray (PrimState m)) | ||
44 | |||
45 | newSource :: PrimMonad m => | ||
46 | String -- ^ name for debug/print purposes. | ||
47 | -> Usize_t -- ^ block size | ||
48 | -> Xoff_t -- ^ maximum visible buffer (Suggested: set same as block size). | ||
49 | -- Rounds up to approx 16k. | ||
50 | -> m (Source m) | ||
51 | newSource nm blksz maxwinsz = do | ||
52 | let bsname = encodeUtf8 $ T.pack nm | ||
53 | src <- newPinnedByteArray $ 1 + B.length bsname + #{const sizeof(xd3_source)} | ||
54 | nptr <- writeStringAt src #{const sizeof(xd3_source)} bsname | ||
55 | writeAtByte src (#{off xd3_source, blksize }) blksz | ||
56 | writeAtByte src (#{off xd3_source, name }) nptr | ||
57 | writeAtByte src (#{off xd3_source, max_winsize}) maxwinsz | ||
58 | writeAtByte src (#{off xd3_source, curblkno }) (maxBound :: Xoff_t) | ||
59 | return $ Source src | ||
60 | |||
61 | sourcePtr :: Source m -> Ptr Xd3Source | ||
62 | sourcePtr (Source src) = ptr (mutableByteArrayContents src) | ||
63 | |||
64 | sourceRequestedBlocknumber :: PrimMonad m => Source m -> m Xoff_t | ||
65 | sourceRequestedBlocknumber (Source src) = readAtByte src (#{off xd3_source, getblkno}) | ||
66 | |||
67 | data CurrentBlock = CurrentBlock | ||
68 | { blkno :: !Xoff_t -- ^ current block number | ||
69 | , blkSize :: !Usize_t -- ^ number of bytes on current block: must be >= 0 and <= 'srcBlockSize' | ||
70 | , blkPtr :: !(Ptr Word8) -- ^ current block array | ||
71 | } | ||
72 | |||
73 | sourceWriteCurrentBlock :: PrimMonad m => Source m -> CurrentBlock -> m () | ||
74 | sourceWriteCurrentBlock (Source src) (CurrentBlock no sz ptr) = do | ||
75 | writeAtByte src (#{off xd3_source, curblkno}) no | ||
76 | writeAtByte src (#{off xd3_source, onblk}) sz | ||
77 | writeAtByte src (#{off xd3_source, curblk}) ptr | ||
78 | |||
79 | sourceWriteEOFKnown :: PrimMonad m => Source m -> Bool -> m () | ||
80 | sourceWriteEOFKnown (Source src) False = writeAtByte src (#{off xd3_source, eof_known}) (0 :: #{type int}) | ||
81 | sourceWriteEOFKnown (Source src) True = writeAtByte src (#{off xd3_source, eof_known}) (1 :: #{type int}) | ||
82 | |||
83 | newtype StreamArray m = StreamArray (MutableByteArray (PrimState m)) | ||
84 | |||
85 | newStreamArray :: PrimMonad m => | ||
86 | Maybe String -> m (StreamArray m, CString) | ||
87 | newStreamArray mmatcher = do | ||
88 | let (len,n) = case mmatcher of | ||
89 | Just m -> let n = encodeUtf8 $ T.pack m | ||
90 | in ( #{const sizeof(xd3_stream)} + B.length n + 1 | ||
91 | , n ) | ||
92 | Nothing -> ( #{const sizeof(xd3_stream)}, B.empty ) | ||
93 | s <- newPinnedByteArray len | ||
94 | fillByteArray s 0 #{const sizeof(xd3_stream)} 0 | ||
95 | nptr <- case mmatcher of | ||
96 | Nothing -> writeStringAt s #{const sizeof(xd3_stream)} n | ||
97 | Just _ -> return nullPtr | ||
98 | return (StreamArray s,nptr) | ||
99 | |||
100 | streamArrayPtr :: StreamArray m -> Ptr Xd3Stream | ||
101 | streamArrayPtr (StreamArray s) = ptr (mutableByteArrayContents s) | ||
102 | |||
103 | setFlag :: PrimMonad m => Flags -> StreamArray m -> Bool -> m () | ||
104 | setFlag b (StreamArray s) wantFlush = do | ||
105 | f <- readAtByte s (#{off xd3_stream, flags}) | ||
106 | writeAtByte s (#{off xd3_stream, flags}) | ||
107 | . (coerce :: Flags -> Word32) | ||
108 | $ if wantFlush then Flags f .|. b | ||
109 | else Flags f .&. complement b | ||
110 | |||
111 | setFlush :: PrimMonad m => StreamArray m -> Bool -> m () | ||
112 | setFlush = setFlag XD3_FLUSH | ||
113 | |||
114 | setSkipWindow :: PrimMonad m => StreamArray m -> Bool -> m () | ||
115 | setSkipWindow = setFlag XD3_SKIP_WINDOW | ||
116 | |||
117 | |||
118 | avail_input :: PrimMonad m => StreamArray m -> Ptr a -> Usize_t -> m () | ||
119 | avail_input (StreamArray s) p sz = do | ||
120 | writeAtByte s (#{off xd3_stream, next_in}) p | ||
121 | writeAtByte s (#{off xd3_stream, avail_in}) sz | ||
122 | |||
123 | |||
124 | nextOut :: PrimMonad m => StreamArray m -> ((Ptr Word8, Usize_t) -> m a) -> m a | ||
125 | nextOut (StreamArray s) action = do | ||
126 | buf <- (,) | ||
127 | <$> readAtByte s (#{off xd3_stream, next_out}) | ||
128 | <*> readAtByte s (#{off xd3_stream, avail_out}) | ||
129 | a <- action buf | ||
130 | -- unsafeIOToPrim $ xd3_consume_output (ptr $ mutableByteArrayContents $ streamArray stream) | ||
131 | writeAtByte s #{off xd3_stream, avail_out} (0 :: Usize_t) | ||
132 | return a | ||
133 | |||
134 | |||
135 | -- | Gives some extra information about the latest library error, if any | ||
136 | -- is known. | ||
137 | errorString :: PrimMonad m => StreamArray m -> m String | ||
138 | errorString (StreamArray s) = do | ||
139 | cstring <- readAtByte s (#{off xd3_stream, msg}) | ||
140 | if cstring /= nullPtr | ||
141 | then unsafeIOToPrim $ peekCString cstring -- TODO: avoid unsafeIOToPrim | ||
142 | else return "" | ||
143 | |||
144 | writeCompressorConfig :: (PrimMonad m, _) => MutableByteArray (PrimState m) -> Offset j -> CompressorConfig -> m () | ||
145 | writeCompressorConfig c o sec = do | ||
146 | writeAtByte c (o +. #{off xd3_sec_cfg,ngroups}) (ngroups sec) | ||
147 | writeAtByte c (o +. #{off xd3_sec_cfg,sector_size}) (sector_size sec) | ||
148 | writeAtByte c (o +. #{off xd3_sec_cfg,inefficient}) (inefficient sec) | ||
149 | |||
150 | writeMatcher :: (PrimMonad m, _) => MutableByteArray (PrimState m) -> Offset j -> StringMatcher -> m () | ||
151 | writeMatcher c o sm = do | ||
152 | -- handled elsewhere: const char *name; <- smName :: String | ||
153 | writeAtByte c (o +. #{off xd3_smatcher, string_match }) (smStringMatch sm) | ||
154 | writeAtByte c (o +. #{off xd3_smatcher, large_look }) (smLargeLook sm) | ||
155 | writeAtByte c (o +. #{off xd3_smatcher, large_step }) (smLargeStep sm) | ||
156 | writeAtByte c (o +. #{off xd3_smatcher, small_look }) (smSmallLook sm) | ||
157 | writeAtByte c (o +. #{off xd3_smatcher, small_chain }) (smSmallChain sm) | ||
158 | writeAtByte c (o +. #{off xd3_smatcher, small_lchain }) (smSmallLchain sm) | ||
159 | writeAtByte c (o +. #{off xd3_smatcher, max_lazy }) (smMaxLazy sm) | ||
160 | writeAtByte c (o +. #{off xd3_smatcher, long_enough }) (smLongEnough sm) | ||
161 | |||
162 | packConfig :: PrimMonad m => CString -- ^ Name of software matcher or nullPtr. | ||
163 | -> Config | ||
164 | -> m ByteArray | ||
165 | packConfig nptr cfg = do | ||
166 | c <- newPinnedByteArray #const sizeof(xd3_config) | ||
167 | fillByteArray c 0 #{const sizeof(xd3_config)} 0 | ||
168 | writeAtByte c #{off xd3_config, winsize} (winsize cfg) | ||
169 | writeAtByte c #{off xd3_config, sprevsz} (sprevsz cfg) | ||
170 | writeAtByte c #{off xd3_config, iopt_size} (iopt_size cfg) | ||
171 | writeAtByte c #{off xd3_config, flags} (coerce (flags cfg) :: Word32) | ||
172 | writeCompressorConfig c #{off xd3_config, sec_data} (sec_data cfg) | ||
173 | writeCompressorConfig c #{off xd3_config, sec_inst} (sec_inst cfg) | ||
174 | writeCompressorConfig c #{off xd3_config, sec_addr} (sec_addr cfg) | ||
175 | let msel :: #type xd3_smatch_cfg | ||
176 | msel = either (const #{const XD3_SMATCH_SOFT}) | ||
177 | (fromIntegral . fromEnum) | ||
178 | (smatch_cfg cfg) | ||
179 | writeAtByte c (#{off xd3_config, smatch_cfg}) msel | ||
180 | let mmatcher = either Just (const Nothing) $ smatch_cfg cfg | ||
181 | forM_ mmatcher $ \matcher -> do | ||
182 | let o = #off xd3_config,smatcher_soft | ||
183 | writeAtByte c (o +. (#{off xd3_smatcher, name})) nptr | ||
184 | writeMatcher c o matcher | ||
185 | unsafeFreezeByteArray c | ||
186 | |||
187 | foreign import ccall "xdelta3.h xd3_config_stream" xd3_config_stream :: Ptr Xd3Stream -> Ptr Config -> IO ErrorCode | ||
188 | |||
189 | foreign import ccall "xdelta3.h xd3_free_stream" xd3_free_stream :: Ptr Xd3Stream -> IO () | ||
190 | |||
191 | foreign import ccall "xdelta3.h xd3_abort_stream" xd3_abort_stream :: Ptr Xd3Stream -> IO () | ||
192 | |||
193 | foreign import ccall "xdelta3.h xd3_close_stream" xd3_close_stream :: Ptr Xd3Stream -> IO ErrorCode | ||
194 | |||
195 | |||
196 | foreign import ccall "xdelta3.h xd3_decode_input" xd3_decode_input :: Ptr Xd3Stream -> IO ErrorCode | ||
197 | foreign import ccall "xdelta3.h xd3_encode_input" xd3_encode_input :: Ptr Xd3Stream -> IO ErrorCode | ||
198 | |||
199 | |||
200 | foreign import ccall "xdelta3.h xd3_set_source" xd3_set_source :: Ptr Xd3Stream -> Ptr Xd3Source -> IO ErrorCode | ||
201 | |||
202 | |||