1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
|
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeFamilies #-}
module Data.VCDIFF.XDelta where
import Control.Monad
import Control.Monad.Primitive
import Data.Bits
import qualified Data.ByteString as B
import Data.Coerce
import Data.Int
import Data.Primitive.ByteArray
import Data.Primitive.ByteArray.Util
import qualified Data.Text as T
import Data.Text.Encoding
import Data.VCDIFF.Types
import Data.Word
import Foreign.C.Types
import Foreign.C.String
import Foreign.Ptr
#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>
#include "offset.h"
type instance SizeOf Usize_t = #const sizeof(usize_t)
type instance SizeOf (FunPtr a) = #const sizeof(void(*)())
type instance SizeOf (Ptr a) = #const sizeof(void*)
type instance SizeOf #{type int} = #const sizeof(int)
type instance SizeOf #{type unsigned int} = #const sizeof(unsigned int)
data Xd3Source
newtype Source m = Source (MutableByteArray (PrimState m))
newSource :: PrimMonad m =>
String -- ^ name for debug/print purposes.
-> Usize_t -- ^ block size
-> Xoff_t -- ^ maximum visible buffer (Suggested: set same as block size).
-- Rounds up to approx 16k.
-> m (Source m)
newSource 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 (#{off xd3_source, blksize }) blksz
writeAtByte src (#{off xd3_source, name }) nptr
writeAtByte src (#{off xd3_source, max_winsize}) maxwinsz
writeAtByte src (#{off xd3_source, curblkno }) (maxBound :: Xoff_t)
return $ Source src
sourcePtr :: Source m -> Ptr Xd3Source
sourcePtr (Source src) = ptr (mutableByteArrayContents src)
sourceRequestedBlocknumber :: PrimMonad m => Source m -> m Xoff_t
sourceRequestedBlocknumber (Source src) = readAtByte src (#{off xd3_source, getblkno})
data CurrentBlock = CurrentBlock
{ blkno :: !Xoff_t -- ^ current block number
, blkSize :: !Usize_t -- ^ number of bytes on current block: must be >= 0 and <= 'srcBlockSize'
, blkPtr :: !(Ptr Word8) -- ^ current block array
}
sourceWriteCurrentBlock :: PrimMonad m => Source m -> CurrentBlock -> m ()
sourceWriteCurrentBlock (Source src) (CurrentBlock no sz ptr) = do
writeAtByte src (#{off xd3_source, curblkno}) no
writeAtByte src (#{off xd3_source, onblk}) sz
writeAtByte src (#{off xd3_source, curblk}) ptr
sourceWriteEOFKnown :: PrimMonad m => Source m -> Bool -> m ()
sourceWriteEOFKnown (Source src) False = writeAtByte src (#{off xd3_source, eof_known}) (0 :: #{type int})
sourceWriteEOFKnown (Source src) True = writeAtByte src (#{off xd3_source, eof_known}) (1 :: #{type int})
newtype StreamArray m = StreamArray (MutableByteArray (PrimState m))
newStreamArray :: PrimMonad m =>
Maybe String -> m (StreamArray m, CString)
newStreamArray mmatcher = do
let (len,n) = case mmatcher of
Just m -> let n = encodeUtf8 $ T.pack m
in ( #{const sizeof(xd3_stream)} + B.length n + 1
, n )
Nothing -> ( #{const sizeof(xd3_stream)}, B.empty )
s <- newPinnedByteArray len
fillByteArray s 0 #{const sizeof(xd3_stream)} 0
nptr <- case mmatcher of
Nothing -> writeStringAt s #{const sizeof(xd3_stream)} n
Just _ -> return nullPtr
return (StreamArray s,nptr)
streamArrayPtr :: StreamArray m -> Ptr Xd3Stream
streamArrayPtr (StreamArray s) = ptr (mutableByteArrayContents s)
setFlag :: PrimMonad m => Flags -> StreamArray m -> Bool -> m ()
setFlag b (StreamArray s) wantFlush = do
f <- readAtByte s (#{off xd3_stream, flags})
writeAtByte s (#{off xd3_stream, flags})
. (coerce :: Flags -> Word32)
$ if wantFlush then Flags f .|. b
else Flags f .&. complement b
setFlush :: PrimMonad m => StreamArray m -> Bool -> m ()
setFlush = setFlag XD3_FLUSH
setSkipWindow :: PrimMonad m => StreamArray m -> Bool -> m ()
setSkipWindow = setFlag XD3_SKIP_WINDOW
avail_input :: PrimMonad m => StreamArray m -> Ptr a -> Usize_t -> m ()
avail_input (StreamArray s) p sz = do
writeAtByte s (#{off xd3_stream, next_in}) p
writeAtByte s (#{off xd3_stream, avail_in}) sz
nextOut :: PrimMonad m => StreamArray m -> ((Ptr Word8, Usize_t) -> m a) -> m a
nextOut (StreamArray s) action = do
buf <- (,)
<$> readAtByte s (#{off xd3_stream, next_out})
<*> readAtByte s (#{off xd3_stream, avail_out})
a <- action buf
-- unsafeIOToPrim $ xd3_consume_output (ptr $ mutableByteArrayContents $ streamArray stream)
writeAtByte s #{off xd3_stream, avail_out} (0 :: Usize_t)
return a
-- | Gives some extra information about the latest library error, if any
-- is known.
errorString :: PrimMonad m => StreamArray m -> m String
errorString (StreamArray s) = do
cstring <- readAtByte s (#{off xd3_stream, msg})
if cstring /= nullPtr
then unsafeIOToPrim $ peekCString cstring -- TODO: avoid unsafeIOToPrim
else return ""
writeCompressorConfig :: (PrimMonad m, _) => MutableByteArray (PrimState m) -> Offset j -> CompressorConfig -> m ()
writeCompressorConfig c o sec = do
writeAtByte c (o +. #{off xd3_sec_cfg,ngroups}) (ngroups sec)
writeAtByte c (o +. #{off xd3_sec_cfg,sector_size}) (sector_size sec)
writeAtByte c (o +. #{off xd3_sec_cfg,inefficient}) (inefficient sec)
writeMatcher :: (PrimMonad m, _) => MutableByteArray (PrimState m) -> Offset j -> StringMatcher -> m ()
writeMatcher c o sm = do
-- handled elsewhere: const char *name; <- smName :: String
writeAtByte c (o +. #{off xd3_smatcher, string_match }) (smStringMatch sm)
writeAtByte c (o +. #{off xd3_smatcher, large_look }) (smLargeLook sm)
writeAtByte c (o +. #{off xd3_smatcher, large_step }) (smLargeStep sm)
writeAtByte c (o +. #{off xd3_smatcher, small_look }) (smSmallLook sm)
writeAtByte c (o +. #{off xd3_smatcher, small_chain }) (smSmallChain sm)
writeAtByte c (o +. #{off xd3_smatcher, small_lchain }) (smSmallLchain sm)
writeAtByte c (o +. #{off xd3_smatcher, max_lazy }) (smMaxLazy sm)
writeAtByte c (o +. #{off xd3_smatcher, long_enough }) (smLongEnough sm)
packConfig :: PrimMonad m => CString -- ^ Name of software matcher or nullPtr.
-> Config
-> m ByteArray
packConfig nptr cfg = do
c <- newPinnedByteArray #const sizeof(xd3_config)
fillByteArray c 0 #{const sizeof(xd3_config)} 0
writeAtByte c #{off xd3_config, winsize} (winsize cfg)
writeAtByte c #{off xd3_config, sprevsz} (sprevsz cfg)
writeAtByte c #{off xd3_config, iopt_size} (iopt_size cfg)
writeAtByte c #{off xd3_config, flags} (coerce (flags cfg) :: Word32)
writeCompressorConfig c #{off xd3_config, sec_data} (sec_data cfg)
writeCompressorConfig c #{off xd3_config, sec_inst} (sec_inst cfg)
writeCompressorConfig c #{off 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 (#{off xd3_config, smatch_cfg}) msel
let mmatcher = either Just (const Nothing) $ smatch_cfg cfg
forM_ mmatcher $ \matcher -> do
let o = #off xd3_config,smatcher_soft
writeAtByte c (o +. (#{off xd3_smatcher, name})) nptr
writeMatcher c o matcher
unsafeFreezeByteArray c
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
foreign import ccall "xdelta3.h xd3_decode_input" xd3_decode_input :: Ptr Xd3Stream -> IO ErrorCode
foreign import ccall "xdelta3.h xd3_encode_input" xd3_encode_input :: Ptr Xd3Stream -> IO ErrorCode
foreign import ccall "xdelta3.h xd3_set_source" xd3_set_source :: Ptr Xd3Stream -> Ptr Xd3Source -> IO ErrorCode
|
