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/Index.hs | 39 +++++++-------- src/Main.hs | 2 +- src/ZNC.hs | 146 ------------------------------------------------------ src/ZNC/Parser.hs | 139 +++++++++++++++++++++++++++++++++++++++++++++++++++ src/ZNC/Slow.hs | 146 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/ZNC2.hs | 129 ----------------------------------------------- 6 files changed, 305 insertions(+), 296 deletions(-) delete mode 100644 src/ZNC.hs create mode 100644 src/ZNC/Parser.hs create mode 100644 src/ZNC/Slow.hs delete mode 100644 src/ZNC2.hs (limited to 'src') diff --git a/src/Index.hs b/src/Index.hs index 221be78..d9a1379 100644 --- a/src/Index.hs +++ b/src/Index.hs @@ -26,7 +26,6 @@ import Control.Monad (forM, forM_, when, guard) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe import Data.ByteString qualified as BS -import Data.ByteString (ByteString) import Data.Char (isDigit, chr, ord) import Data.Functor ((<&>)) import Data.IORef @@ -43,7 +42,6 @@ import Data.Vector.Generic qualified as VG import Data.Vector.Generic.Mutable qualified as VGM import Data.Vector.Unboxed qualified as VU import Data.Vector.Unboxed.Base qualified as VU (Vector(V_2)) -import Data.Vector.Storable qualified as VS import Data.Word import System.Clock qualified as Clock import System.Directory @@ -59,7 +57,7 @@ import Config (Channel(..), prettyChannel) import ImmutGrowVector qualified as IGV import Mmap import Util -import ZNC +import ZNC.Parser -- This module keeps an index both for the full list of events, as well as a @@ -136,7 +134,7 @@ ciEndDay ci = -- simple data structure is fine. data Index = Index !FilePath !(Map Channel (IORef ChanIndex)) - !(Cache (Channel, YMD) (ByteString, VS.Vector Word32)) + !(Cache (Channel, YMD) RawEvents) type EventID = Text @@ -287,8 +285,9 @@ indexUpdateImport index@(Index _ mp _) chan = do dayidx = fromIntegral @Integer @Int (day `diffDays` ciStartDay ci) loadDay index chan ymd >>= \case - Just (bs, lineStarts) -> - return (Just (dayidx, Counts (VS.length lineStarts) (countCompressed (map snd (parseLog bs))))) + Just raw -> + return (Just (dayidx, Counts (rawNumEvents raw) + (countCompressed (map snd (realiseEvents raw))))) Nothing -> return Nothing atomicPrint $ "Update import for " <> prettyChannel chan <> ": " <> T.show readCounts <> " (len = " <> T.show (IGV.length (ciCountUntil ci)) <> ")" @@ -375,17 +374,17 @@ indexGetEventsLinear index@(Index _ mp _) chan kind from count = do | otherwise = scan IGV.! dayidx - scan IGV.! (dayidx - 1) rangeStart = if day == day1 then off1 else 0 rangeEnd = if day == day2 then off2 else neventsOnDay - range = (rangeStart, Just (rangeEnd - rangeStart)) + range = (rangeStart, rangeEnd) ymd = ymdFromGregorian (toGregorian day) in if neventsOnDay > 0 then loadDay index chan ymd <&> \case - Just (bs, lineStarts) -> case kind of + Just raw -> case kind of CKAll -> - let events = parseLogRange range lineStarts bs + let events = realiseEventsRange raw range in [(YMDHMS ymd hms, genEventID (YMDHMS ymd hms) off, ev) | ((hms, ev), off) <- zip events [rangeStart ..]] CKCompressed -> - let events = parseLog bs + let events = realiseEvents raw events' = take (rangeEnd - rangeStart) $ drop rangeStart $ compressEvents [((hms, off), ev) | ((hms, ev), off) <- zip events [0..]] in [(YMDHMS ymd hms, genEventID (YMDHMS ymd hms) off, ev) | ((hms, off), ev) <- events'] @@ -429,16 +428,16 @@ findEventIDLinear index@(Index _ mp _) chan kind eid = runMaybeT $ do ci <- lift $ readIORef (mp Map.! chan) guard (ciStartDay ci <= day && day <= ciEndDay ci) - (bs, lineStarts) <- MaybeT $ loadDay index chan ymd + raw <- MaybeT $ loadDay index chan ymd let candidates = -- [(event offset, index in possibly compressed event list)] map snd $ takeWhile ((== hms) . fst) $ dropWhile ((< hms) . fst) $ case kind of - CKAll -> zip (parseLogTimesOnly lineStarts bs) (zip [0..] [0..]) + CKAll -> zip (map fst (realiseEvents raw)) (zip [0..] [0..]) CKCompressed -> let compressed = compressEvents [((hms', off), ev) - | ((hms', ev), off) <- zip (parseLog bs) [0..]] + | ((hms', ev), off) <- zip (realiseEvents raw) [0..]] in [(hms', (off, idx)) | (((hms', off), _ev), idx) <- zip compressed [0..]] case candidates of [] -> empty @@ -473,8 +472,8 @@ indexGetEventsDay index@(Index _ mp _) chan kind day = do if day < ciStartDay ci || day > ciEndDay ci then return (firstlast, []) else loadDay index chan ymd <&> \case - Just (bs, _lineStarts) -> - let events = parseLog bs + Just raw -> + let events = realiseEvents raw events' = case kind of CKAll -> [(hms, genEventID (YMDHMS ymd hms) off, ev) @@ -488,17 +487,17 @@ indexGetEventsDay index@(Index _ mp _) chan kind day = do -- utilities -loadDay :: Index -> Channel -> YMD -> IO (Maybe (ByteString, VS.Vector Word32)) +loadDay :: Index -> Channel -> YMD -> IO (Maybe RawEvents) loadDay (Index basedir _ cache) chan@(Channel network channel) ymd = do cacheLookup cache (chan, ymd) >>= \case Nothing -> do mapFile (basedir T.unpack network T.unpack channel toFileName ymd) >>= \case Just bs -> do - let lineStarts = preparseLog bs - cacheAdd cache (chan, ymd) (bs, lineStarts) - return (Just (bs, lineStarts)) + let raw = parseLogRaw bs + cacheAdd cache (chan, ymd) raw + return (Just raw) Nothing -> return Nothing -- file didn't exist - Just (bs, lineStarts) -> return (Just (bs, lineStarts)) + Just raw -> return (Just raw) isImportant :: Event -> Bool isImportant ReNick{} = True diff --git a/src/Main.hs b/src/Main.hs index a06aef8..e592fce 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -31,7 +31,7 @@ import Config import Index import Pages import Util -import ZNC +import ZNC.Parser sendHtml200 :: ByteString -> IO Response diff --git a/src/ZNC.hs b/src/ZNC.hs deleted file mode 100644 index 502b272..0000000 --- a/src/ZNC.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module ZNC ( - -- 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) 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) diff --git a/src/ZNC2.hs b/src/ZNC2.hs deleted file mode 100644 index bcd4fb3..0000000 --- a/src/ZNC2.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# 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 #) -- cgit v1.3.1