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
|
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UnliftedFFITypes #-}
module ZNC2 where
import Data.Array.Byte
import Data.ByteString (ByteString)
import Data.ByteString.Unsafe qualified as BS
import Data.Text (Text)
import Data.Text.Internal qualified as TI
import Data.Text.Internal.Validate (isValidUtf8ByteArray)
import Foreign.C.Types
import Foreign.Ptr
import GHC.Exts
import GHC.IO (IO(IO))
import GHC.Word
import System.IO.Unsafe (unsafePerformIO)
import Util
import ZNC (Event(..))
foreign import ccall unsafe "tirclogv_parse_znc_numevents"
-- file buf length num events
c_parse_znc_numevents :: Ptr CChar -> CSize -> IO CSize
foreign import ccall unsafe "tirclogv_parse_znc"
-- events buffer file buf length
c_parse_znc :: MutableByteArray# RealWorld -> Ptr CChar -> CSize -> IO ()
foreign import ccall unsafe "tirclogv_fix_utf8_length"
-- byte buf offset length length of fixed
c_fix_utf8_length :: ByteArray# -> CSize -> CSize -> IO CSize
foreign import ccall unsafe "tirclogv_fix_utf8"
-- output buffer byte buf offset length
c_fix_utf8 :: MutableByteArray# RealWorld -> ByteArray# -> CSize -> CSize -> IO ()
-- For each event: (total 22 bytes)
-- * 1 byte hour
-- * 1 byte minute
-- * 1 byte second
-- * 1 byte event kind
-- * 4 bytes text pointer 1
-- * 4 bytes text pointer 2
-- * 4 bytes text pointer 3
-- * 2 bytes text length 1
-- * 2 bytes text length 2
-- * 2 bytes text length 3
data Events = Events ByteArray# -- pinned
evRepSz :: Int
evRepSz = 20
parseLog :: ByteString -> [(HMS, Event)]
parseLog bs =
let !(Events ba#) = parseLogToEvents bs
nev = I# (sizeofByteArray# ba#) `quot` evRepSz
in [deserialise ba# i | i <- [0 .. nev-1]]
where
deserialise :: ByteArray# -> Int -> (HMS, Event)
deserialise ba# i =
(HMS (byte 0) (byte 1) (byte 2)
,case byte 3 of
0 -> Join (textfield 0) (textfield 1)
1 -> Part (textfield 0) (textfield 1) (textfield 2)
2 -> Quit (textfield 0) (textfield 1) (textfield 2)
3 -> ReNick (textfield 0) (textfield 1)
4 -> Talk (textfield 0) (textfield 1)
5 -> Notice (textfield 0) (textfield 1)
6 -> Act (textfield 0) (textfield 1)
7 -> Kick (textfield 0) (textfield 1) (textfield 2)
8 -> Mode (textfield 0) (textfield 1)
9 -> Topic (textfield 0) (textfield 1)
_ {- includes 10 -} -> ParseError
)
where
byte :: Int -> Word8
byte off = indexWord8Array ba# (i * evRepSz + off)
textfield :: Int -> Text
textfield n =
let offset = fromIntegral @Word32 @Int (indexWord8ArrayAsWord32 ba# (i * evRepSz + 4 + 4 * n))
len = fromIntegral @Word16 @Int (indexWord8ArrayAsWord16 ba# (i * evRepSz + 16 + 2 * n))
in if isValidUtf8ByteArray (ByteArray ba#) offset len
then TI.Text (ByteArray ba#) offset len
else fixUtf8ByteArray ba# offset len
indexWord8ArrayAsWord32 :: ByteArray# -> Int -> Word32
indexWord8ArrayAsWord32 ba# (I# i#) = W32# (indexWord8ArrayAsWord32# ba# i#)
indexWord8ArrayAsWord16 :: ByteArray# -> Int -> Word16
indexWord8ArrayAsWord16 ba# (I# i#) = W16# (indexWord8ArrayAsWord16# ba# i#)
indexWord8Array :: ByteArray# -> Int -> Word8
indexWord8Array ba# (I# i#) = W8# (indexWord8Array# ba# i#)
{-# NOINLINE parseLogToEvents #-}
parseLogToEvents :: ByteString -> Events
parseLogToEvents bs = unsafePerformIO $
BS.unsafeUseAsCStringLen bs $ \(bsptr, bslen) -> do
let bslenCS = fromIntegral @Int @CSize bslen
numev <- c_parse_znc_numevents bsptr bslenCS
let !(I# numbytes#) = fromIntegral @CSize @Int numev * evRepSz
MutableByteArray dst# <-
IO $ \s -> case newPinnedByteArray# numbytes# s of
(# s', mba# #) -> (# s', MutableByteArray mba# #)
c_parse_znc dst# bsptr bslenCS
IO $ \s -> case unsafeFreezeByteArray# dst# s of
(# s', ba# #) -> (# s', Events ba# #)
-- | Returns an unpinned byte array
{-# NOINLINE fixUtf8ByteArray #-}
fixUtf8ByteArray :: ByteArray# -> Int -> Int -> Text
fixUtf8ByteArray input# offset len = unsafePerformIO $ do
let offCS = fromIntegral @Int @CSize offset
lenCS = fromIntegral @Int @CSize len
outlenCS <- c_fix_utf8_length input# offCS lenCS
let !outlen@(I# outlen#) = fromIntegral @CSize @Int outlenCS
MutableByteArray dst# <-
IO $ \s -> case newByteArray# outlen# s of
(# s', mba# #) -> (# s', MutableByteArray mba# #)
c_fix_utf8 dst# input# offCS lenCS
IO $ \s -> case unsafeFreezeByteArray# dst# s of
(# s', ba# #) -> (# s', TI.Text (ByteArray ba#) 0 outlen #)
|
