summaryrefslogtreecommitdiff
path: root/src/ZNC
diff options
context:
space:
mode:
Diffstat (limited to 'src/ZNC')
-rw-r--r--src/ZNC/Parser.hs139
-rw-r--r--src/ZNC/Slow.hs146
2 files changed, 285 insertions, 0 deletions
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)
generated by cgit v1.3.1 (git 2.54.0) at 2026-08-07 11:00:11 +0200