From 9082745e03a06b5471aa23b7a84bb2c4d8b4f304 Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Sun, 26 Jul 2026 20:47:21 +0100 Subject: Debug and optimise C znc parser --- src/ZNC/Parser.hs | 139 +++++++++++++++++++++++++++++++++++++++++++++++++++ src/ZNC/Slow.hs | 146 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 285 insertions(+) create mode 100644 src/ZNC/Parser.hs create mode 100644 src/ZNC/Slow.hs (limited to 'src/ZNC') diff --git a/src/ZNC/Parser.hs b/src/ZNC/Parser.hs new file mode 100644 index 0000000..1a31840 --- /dev/null +++ b/src/ZNC/Parser.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} +module ZNC.Parser ( + Nick, Event(..), + parseLog, + RawEvents, rawNumEvents, realiseEvents, realiseEventsRange, parseLogRaw, +) where + +import Data.Array.Byte +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Unsafe qualified as BSU +import Data.Text (Text) +import Data.Text.Encoding qualified as TE +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 + + +foreign import ccall unsafe "tirclogv_count_lines" + -- file buf length num events + c_count_lines :: Ptr CChar -> CSize -> IO CSize + +foreign import ccall unsafe "tirclogv_parse_znc" + -- events buffer evbufsz file buf length actual num events + c_parse_znc :: MutableByteArray# RealWorld -> CSize -> Ptr CChar -> CSize -> IO CSize + + +type Nick = Text + +-- Adapted from clogparse by Keegan McAllister (BSD3) (https://hackage.haskell.org/package/clogparse). +data Event + = Join Nick Text -- ^ User joined. + | Part Nick Text Text -- ^ User left the channel. (address, reason) + | Quit Nick Text Text -- ^ User quit the server. (address, reason) + | ReNick Nick Nick -- ^ User changed from one to another nick. + | Talk Nick Text -- ^ User spoke (@PRIVMSG@). + | Notice Nick Text -- ^ User spoke (@NOTICE@). + | Act Nick Text -- ^ User acted (@CTCP ACTION@). + | Kick Nick Nick Text -- ^ User was kicked by user. (kicked, kicker, reason) + | Mode Nick Text -- ^ User set mode on the channel. + | Topic Nick Text -- ^ Topic change. + | ParseError + | Compressed Text -- ^ Fake event generated when compressing multiple meta events in "Index" + deriving (Show) + + +-- For each event: (`struct event` on the C sode; 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 +evRepSz :: Int +evRepSz = 22 + +-- | Retains the original ByteString. +data RawEvents = RawEvents + ByteString -- original data parsed + Int -- actual number of events (may be smaller than allocated capacity in ByteArray#) + ByteArray# -- parsed array of `struct event`; pinned + +parseLog :: ByteString -> [(HMS, Event)] +parseLog = realiseEvents . parseLogRaw + +rawNumEvents :: RawEvents -> Int +rawNumEvents (RawEvents _ nev _) = nev + +-- | This is a good list producer. +realiseEvents :: RawEvents -> [(HMS, Event)] +realiseEvents raw@(RawEvents _ nev _) = realiseEventsRange raw (0, nev) + +-- | This is a good list producer. Range is (inclusive, exclusive). +realiseEventsRange :: RawEvents -> (Int, Int) -> [(HMS, Event)] +realiseEventsRange (RawEvents bs _ ba#) (startidx, endidx) = + [deserialise i | i <- [startidx .. endidx - 1]] + where + deserialise :: Int -> (HMS, Event) + deserialise i = + (HMS (byte 0) (byte 1) (byte 2) + ,case byte 3 of + 1 -> Join (textfield 0) (textfield 1) + 2 -> Part (textfield 0) (textfield 1) (textfield 2) + 3 -> Quit (textfield 0) (textfield 1) (textfield 2) + 4 -> ReNick (textfield 0) (textfield 1) + 5 -> Talk (textfield 0) (textfield 1) + 6 -> Notice (textfield 0) (textfield 1) + 7 -> Act (textfield 0) (textfield 1) + 8 -> Kick (textfield 0) (textfield 1) (textfield 2) + 9 -> Mode (textfield 0) (textfield 1) + 10 -> Topic (textfield 0) (textfield 1) + _ {- includes 0 -} -> ParseError + ) + where + byte :: Int -> Word8 + byte off = readWord8 (i * evRepSz + off) + + textfield :: Int -> Text + textfield n = + let offset = fromIntegral @Word32 @Int (readWord32 (i * evRepSz + 4 + 4 * n)) + len = fromIntegral @Word16 @Int (readWord16 (i * evRepSz + 16 + 2 * n)) + in TE.decodeUtf8Lenient (BS.take len (BS.drop offset bs)) + + readWord32 :: Int -> Word32 + readWord32 (I# i#) = W32# (indexWord8ArrayAsWord32# ba# i#) + + readWord16 :: Int -> Word16 + readWord16 (I# i#) = W16# (indexWord8ArrayAsWord16# ba# i#) + + readWord8 :: Int -> Word8 + readWord8 (I# i#) = W8# (indexWord8Array# ba# i#) + +-- | The 'ByteString' is retained inside the 'RawEvents'. +{-# NOINLINE parseLogRaw #-} +parseLogRaw :: ByteString -> RawEvents +parseLogRaw bs = unsafePerformIO $ + BSU.unsafeUseAsCStringLen bs $ \(bsptr, bslen) -> do + let bslenCS = fromIntegral @Int @CSize bslen + numev <- c_count_lines bsptr bslenCS + let !(I# numbytes#) = fromIntegral @CSize @Int numev * evRepSz + + MutableByteArray dst# <- + IO $ \s -> case newPinnedByteArray# numbytes# s of + (# s', mba# #) -> (# s', MutableByteArray mba# #) + realnumev <- c_parse_znc dst# numev bsptr bslenCS + IO $ \s -> case unsafeFreezeByteArray# dst# s of + (# s', ba# #) -> (# s', RawEvents bs (fromIntegral @CSize @Int realnumev) ba# #) diff --git a/src/ZNC/Slow.hs b/src/ZNC/Slow.hs new file mode 100644 index 0000000..0d7666f --- /dev/null +++ b/src/ZNC/Slow.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE OverloadedStrings #-} +module ZNC.Slow ( + -- Log(..), + Nick, Event(..), + preparseLog, + parseLog, parseLogRange, + parseLogTimesOnly, +) where + +import Control.Applicative +import Data.Attoparsec.ByteString.Char8 qualified as P +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BS8 +import Data.Char (ord) +import Data.Either (fromRight) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE +import Data.Vector.Storable qualified as VS +import Data.Word (Word8, Word32) + +import Util + + +type Nick = Text + +-- Adapted from clogparse by Keegan McAllister (BSD3) (https://hackage.haskell.org/package/clogparse). +data Event + = Join Nick Text -- ^ User joined. + | Part Nick Text Text -- ^ User left the channel. (address, reason) + | Quit Nick Text Text -- ^ User quit the server. (address, reason) + | ReNick Nick Nick -- ^ User changed from one to another nick. + | Talk Nick Text -- ^ User spoke (@PRIVMSG@). + | Notice Nick Text -- ^ User spoke (@NOTICE@). + | Act Nick Text -- ^ User acted (@CTCP ACTION@). + | Kick Nick Nick Text -- ^ User was kicked by user. (kicked, kicker, reason) + | Mode Nick Text -- ^ User set mode on the channel. + | Topic Nick Text -- ^ Topic change. + | ParseError + | Compressed Text -- ^ Fake event generated when compressing multiple meta events in "Index" + deriving (Show) + +-- | Returned vector has one entry for each line in the file, excepting the +-- empty "line" after the final newline, if any. +preparseLog :: ByteString -> VS.Vector Word32 +preparseLog = VS.fromList . findLineStarts 0 + where + findLineStarts :: Int -> ByteString -> [Word32] + findLineStarts off bs = + case BS.findIndex (== 10) (BS.drop off bs) of + Nothing | BS.length bs == off -> [] + | otherwise -> [fromIntegral off] + Just i -> fromIntegral off : findLineStarts (off + i + 1) bs + +-- these INLINE/NOINLINE pragmas are optimisation without testing or profiling, have fun +{-# INLINE parseLog #-} +parseLog :: ByteString -> [(HMS, Event)] +parseLog = map parseLogLine . BS8.lines + +{-# INLINE parseLogTimesOnly #-} +parseLogTimesOnly :: VS.Vector Word32 -> ByteString -> [HMS] +parseLogTimesOnly linestarts bs = + map (fromRight (HMS 0 0 0) . P.parseOnly parseTOD) $ + splitWithLineStarts 0 linestarts bs + +-- (start line, number of lines (default to rest of file)) +{-# INLINE parseLogRange #-} +parseLogRange :: (Int, Maybe Int) -> VS.Vector Word32 -> ByteString -> [(HMS, Event)] +parseLogRange (startln, mnumln) linestarts topbs = + let numln = fromMaybe (VS.length linestarts - startln) mnumln + splitted = splitWithLineStarts 0 (VS.slice startln numln linestarts) topbs + in -- traceShow ("pLR"::String, splitted) $ + map parseLogLine splitted + +{-# INLINE splitWithLineStarts #-} +splitWithLineStarts :: Int -> VS.Vector Word32 -> ByteString -> [ByteString] +splitWithLineStarts idx starts bs + | idx >= VS.length starts = [] + | idx == VS.length starts - 1 = + [BS.takeWhile (\b -> b /= 13 && b /= 10) (BS.drop (at idx) bs)] + | otherwise = + trimCR (BS.drop (at idx) (BS.take (at (idx + 1) - 1) bs)) + : splitWithLineStarts (idx + 1) starts bs + where + at i = fromIntegral @Word32 @Int (starts VS.! i) + + trimCR :: ByteString -> ByteString + trimCR b = case BS.unsnoc b of + Just (b', c) | c == 13 -> b' + _ -> b + +{-# NOINLINE parseLogLine #-} +parseLogLine :: ByteString -> (HMS, Event) +parseLogLine = fromRight (HMS 0 0 0, ParseError) . P.parseOnly parseLine + +parseLine :: P.Parser (HMS, Event) +parseLine = (,) <$> parseTOD <*> parseEvent + +parseTOD :: P.Parser HMS +parseTOD = do + _ <- P.char '[' + tod <- HMS <$> pTwoDigs <*> (P.char ':' >> pTwoDigs) <*> (P.char ':' >> pTwoDigs) + _ <- P.string "] " + return tod + +-- Adapted from clogparse by Keegan McAllister (BSD3) (https://hackage.haskell.org/package/clogparse). +parseEvent :: P.Parser Event +parseEvent = asum + [ P.string "*** " *> asum + [ userAct Join "Joins: " + , userAct' Part "Parts: " + , userAct' Quit "Quits: " + , ReNick <$> nick <*> (P.string " is now known as " *> nick) + , Mode <$> nick <*> (P.string " sets mode: " *> remaining) + , Kick <$> (nick <* P.string " was kicked by ") <*> nick <* P.char ' ' <*> encloseTail '(' ')' + , Topic <$> (nick <* P.string " changes topic to ") <*> encloseTail '\'' '\'' + ] + , Talk <$ P.char '<' <*> nick <* P.string "> " <*> remaining + , Notice <$ P.char '-' <*> (stripFinalDash =<< nick) <*> (P.char ' ' *> remaining) + , Act <$ P.string "* " <*> nick <* P.char ' ' <*> remaining + ] where + nick = utf8 <$> P.takeWhile (not . P.inClass " \n\r\t\v<>") + userAct f x = f <$ P.string x <*> nick <* P.char ' ' <*> parens + userAct' f x = f <$ P.string x <*> nick <* P.char ' ' <*> parens <* P.char ' ' <*> encloseTail '(' ')' + parens = P.char '(' >> (utf8 <$> P.takeWhile (/= ')')) <* P.char ')' + encloseTail c1 c2 = do _ <- P.char c1 + bs <- P.takeByteString + case BS.unsnoc bs of + Just (s, c) | c == fromIntegral (ord c2) -> return (utf8 s) + _ -> fail "Wrong end char" + stripFinalDash n = case T.unsnoc n of + Just (n', '-') -> return n' + _ -> empty + utf8 = TE.decodeUtf8Lenient + remaining = utf8 <$> P.takeByteString + +pTwoDigs :: P.Parser Word8 +pTwoDigs = do + let digit = do + c <- P.satisfy (\c -> '0' <= c && c <= '9') + return (fromIntegral (ord c - ord '0')) + c1 <- digit + c2 <- digit + return (10 * c1 + c2) -- cgit v1.3.1