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
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
|
{-# 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.Primitive.MutVar
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 m = Stream
{ streamArray :: MutableByteArray (PrimState m)
, streamPtr :: ForeignPtr Xd3Stream
, streamSource :: MutVar (PrimState m) (Maybe (MutableByteArray (PrimState m)))
}
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 :: PrimMonad m => Config -> m (Either ErrorCode (Stream m))
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 <- newMutVar Nothing
stream <- unsafeIOToPrim $ 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
}
unsafeIOToPrim (xd3_config_stream sptr cptr) >>= \case
XD3_SUCCESS -> return $ c `seq` Right stream
ecode -> return $ Left ecode
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
data Xd3Source
foreign import ccall "xdelta3.h xd3_set_source" xd3_set_source :: Ptr Xd3Stream -> Ptr Xd3Source -> IO ErrorCode
set_source :: PrimMonad m =>
Stream m -> String -- ^ name for debug/print purposes.
-> Usize_t -- ^ block size
-> Xoff_t -- ^ maximum visible buffer
-> m ()
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)
unsafeIOToPrim (xd3_set_source strm srcptr)
writeMutVar (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 :: PrimMonad m => Stream m -> Bool -> m ()
setFlush stream wantFlush = return () -- todo
setSkipWindow :: PrimMonad m => Stream m -> Bool -> m ()
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
-}
|
