diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Index.hs | 39 | ||||
| -rw-r--r-- | src/Main.hs | 2 | ||||
| -rw-r--r-- | src/ZNC/Parser.hs | 139 | ||||
| -rw-r--r-- | src/ZNC/Slow.hs (renamed from src/ZNC.hs) | 2 | ||||
| -rw-r--r-- | src/ZNC2.hs | 129 |
5 files changed, 160 insertions, 151 deletions
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/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.hs b/src/ZNC/Slow.hs index 502b272..0d7666f 100644 --- a/src/ZNC.hs +++ b/src/ZNC/Slow.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module ZNC ( +module ZNC.Slow ( -- Log(..), Nick, Event(..), preparseLog, 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 #) |