{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
module GHC.RTS.EventParserUtils (
        EventParser(..),
        EventParsers(..),

        getString,
        getText,
        getTextNul,
        mkEventTypeParsers,
        simpleEvent,
        skip,
    ) where

import Data.Array
import Data.Binary
import Data.Binary.Get ()
import Data.Binary.Put ()
import Data.IntMap (IntMap)
import Data.List
import Data.Text (Text)
import qualified Data.Binary.Get as G
import qualified Data.ByteString.Char8 as B8
import qualified Data.IntMap as M
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE

#define EVENTLOG_CONSTANTS_ONLY
#include "EventLogFormat.h"

import GHC.RTS.EventTypes

newtype EventParsers = EventParsers (Array Int (Get EventInfo))

getString :: Integral a => a -> Get String
getString :: forall a. Integral a => a -> Get String
getString a
len = do
  ByteString
bytes <- Int -> Get ByteString
G.getByteString forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral a
len
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! ByteString -> String
B8.unpack ByteString
bytes

-- | Decode a given length of bytes as a 'Text'
getText
  :: Integral a
  => a -- ^ Number of bytes to decode
  -> Get Text
getText :: forall a. Integral a => a -> Get Text
getText a
len = do
  ByteString
bytes <- Int -> Get ByteString
G.getByteString forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral a
len
  case ByteString -> Either UnicodeException Text
TE.decodeUtf8' ByteString
bytes of
    Left UnicodeException
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show UnicodeException
err
    Right Text
text -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
text

-- | Decode a null-terminated string as a 'Text'
getTextNul :: Get Text
getTextNul :: Get Text
getTextNul = do
  ByteString
chunks <- Get ByteString
G.getLazyByteStringNul
  case ByteString -> Either UnicodeException Text
TLE.decodeUtf8' ByteString
chunks of
    Left UnicodeException
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show UnicodeException
err
    Right Text
text -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.toStrict Text
text

skip :: Integral a => a -> Get ()
skip :: forall a. Integral a => a -> Get ()
skip a
n = Int -> Get ()
G.skip (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n)

--
-- Code to build the event parser table.
--

--
-- | Event parser data. Parsers are either fixed or variable size.
--
data EventParser a
    = FixedSizeParser {
        forall a. EventParser a -> Int
fsp_type        :: Int,
        forall a. EventParser a -> Word16
fsp_size        :: EventTypeSize,
        forall a. EventParser a -> Get a
fsp_parser      :: Get a
    }
    | VariableSizeParser {
        forall a. EventParser a -> Int
vsp_type        :: Int,
        forall a. EventParser a -> Get a
vsp_parser      :: Get a
    }

getParser :: EventParser a -> Get a
getParser :: forall a. EventParser a -> Get a
getParser (FixedSizeParser Int
_ Word16
_ Get a
p) = Get a
p
getParser (VariableSizeParser Int
_ Get a
p) = Get a
p

getType :: EventParser a -> Int
getType :: forall a. EventParser a -> Int
getType (FixedSizeParser Int
t Word16
_ Get a
_) = Int
t
getType (VariableSizeParser Int
t Get a
_) = Int
t

isFixedSize :: EventParser a -> Bool
isFixedSize :: forall a. EventParser a -> Bool
isFixedSize (FixedSizeParser {}) = Bool
True
isFixedSize (VariableSizeParser {}) = Bool
False

simpleEvent :: Int -> a -> EventParser a
simpleEvent :: forall a. Int -> a -> EventParser a
simpleEvent Int
t a
p = forall a. Int -> Word16 -> Get a -> EventParser a
FixedSizeParser Int
t Word16
0 (forall (m :: * -> *) a. Monad m => a -> m a
return a
p)

-- Our event log format allows new fields to be added to events over
-- time.  This means that our parser must be able to handle:
--
--  * old versions of an event, with fewer fields than expected,
--  * new versions of an event, with more fields than expected
--
-- The event log file declares the size for each event type, so we can
-- select the correct parser for the event type based on its size.  We
-- do this once after parsing the header: given the EventTypes, we build
-- an array of event parsers indexed by event type.
--
-- For each event type, we may have multiple parsers for different
-- versions of the event, indexed by size.  These are listed in the
-- eventTypeParsers list below.  For the given log file we select the
-- parser for the most recent version (largest size doesn't exceed the size
-- declared in the header).  If this is a newer version of the event
-- than we understand, there may be extra bytes that we have to read
-- and discard in the parser for this event type.
--
-- Summary:
--   if size is smaller that we expect:
--     parse the earlier version, or ignore the event
--   if size is just right:
--     parse it
--   if size is too big:
--     parse the bits we understand and discard the rest

mkEventTypeParsers :: IntMap EventType
                   -> [EventParser EventInfo]
                   -> Array Int (Get EventInfo)
mkEventTypeParsers :: IntMap EventType
-> [EventParser EventInfo] -> Array Int (Get EventInfo)
mkEventTypeParsers IntMap EventType
etypes [EventParser EventInfo]
event_parsers
 = forall i e a.
Ix i =>
(e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
accumArray (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. a -> b -> a
const) forall a. HasCallStack => a
undefined (Int
0, Int
max_event_num)
    [ (Int
num, Int -> Get EventInfo
parser Int
num) | Int
num <- [Int
0..Int
max_event_num] ]
  where
    max_event_num :: Int
max_event_num = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a. IntMap a -> [Int]
M.keys IntMap EventType
etypes)
    undeclared_etype :: a -> m a
undeclared_etype a
num = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"undeclared event type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
num)
    parser_map :: IntMap [EventParser EventInfo]
parser_map = forall a. [EventParser a] -> IntMap [EventParser a]
makeParserMap [EventParser EventInfo]
event_parsers
    parser :: Int -> Get EventInfo
parser Int
num =
            -- Get the event's size from the header,
            -- the first Maybe describes whether the event was declared in the header.
            -- the second Maybe selects between variable and fixed size events.
        let mb_mb_et_size :: Maybe (Maybe Word16)
mb_mb_et_size = do EventType
et <- forall a. Int -> IntMap a -> Maybe a
M.lookup Int
num IntMap EventType
etypes
                               forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ EventType -> Maybe Word16
size EventType
et
            -- Find a parser for the event with the given size.
            maybe_parser :: Maybe Word16 -> Maybe (Get EventInfo)
maybe_parser Maybe Word16
mb_et_size = do [EventParser EventInfo]
possible <- forall a. Int -> IntMap a -> Maybe a
M.lookup Int
num IntMap [EventParser EventInfo]
parser_map
                                         EventParser EventInfo
best_parser <- case Maybe Word16
mb_et_size of
                                            Maybe Word16
Nothing -> forall a. [EventParser a] -> Maybe (EventParser a)
getVariableParser [EventParser EventInfo]
possible
                                            Just Word16
et_size -> forall a. Word16 -> [EventParser a] -> Maybe (EventParser a)
getFixedParser Word16
et_size [EventParser EventInfo]
possible
                                         forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. EventParser a -> Get a
getParser EventParser EventInfo
best_parser
            in case Maybe (Maybe Word16)
mb_mb_et_size of
                -- This event is declared in the log file's header
                Just Maybe Word16
mb_et_size -> case Maybe Word16 -> Maybe (Get EventInfo)
maybe_parser Maybe Word16
mb_et_size of
                    -- And we have a valid parser for it.
                    Just Get EventInfo
p -> Get EventInfo
p
                    -- But we don't have a valid parser for it.
                    Maybe (Get EventInfo)
Nothing -> Int -> Maybe Word16 -> Get EventInfo
noEventTypeParser Int
num Maybe Word16
mb_et_size
                -- This event is not declared in the log file's header
                Maybe (Maybe Word16)
Nothing -> forall {m :: * -> *} {a} {a}. (MonadFail m, Show a) => a -> m a
undeclared_etype Int
num

-- Find the first variable length parser.
getVariableParser :: [EventParser a] -> Maybe (EventParser a)
getVariableParser :: forall a. [EventParser a] -> Maybe (EventParser a)
getVariableParser [] = forall a. Maybe a
Nothing
getVariableParser (EventParser a
x:[EventParser a]
xs) = case EventParser a
x of
    FixedSizeParser Int
_ Word16
_ Get a
_ -> forall a. [EventParser a] -> Maybe (EventParser a)
getVariableParser [EventParser a]
xs
    VariableSizeParser Int
_ Get a
_ -> forall a. a -> Maybe a
Just EventParser a
x

-- Find the best fixed size parser, that is to say, the parser for the largest
-- event that does not exceed the size of the event as declared in the log
-- file's header.
getFixedParser :: EventTypeSize -> [EventParser a] -> Maybe (EventParser a)
getFixedParser :: forall a. Word16 -> [EventParser a] -> Maybe (EventParser a)
getFixedParser Word16
size [EventParser a]
parsers =
        do EventParser a
parser <- ((forall a. (a -> Bool) -> [a] -> [a]
filter forall a. EventParser a -> Bool
isFixedSize) forall {a} {b} {c}. (a -> b) -> (b -> c) -> a -> c
`pipe`
                      (forall a. (a -> Bool) -> [a] -> [a]
filter (\EventParser a
x -> (forall a. EventParser a -> Word16
fsp_size EventParser a
x) forall a. Ord a => a -> a -> Bool
<= Word16
size)) forall {a} {b} {c}. (a -> b) -> (b -> c) -> a -> c
`pipe`
                      (forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy forall {a} {a}. EventParser a -> EventParser a -> Ordering
descending_size) forall {a} {b} {c}. (a -> b) -> (b -> c) -> a -> c
`pipe`
                      forall {a}. [a] -> Maybe a
maybe_head) [EventParser a]
parsers
           forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Word16 -> EventParser a -> EventParser a
padParser Word16
size EventParser a
parser
    where pipe :: (a -> b) -> (b -> c) -> a -> c
pipe a -> b
f b -> c
g = b -> c
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f
          descending_size :: EventParser a -> EventParser a -> Ordering
descending_size (FixedSizeParser Int
_ Word16
s1 Get a
_) (FixedSizeParser Int
_ Word16
s2 Get a
_) =
            forall a. Ord a => a -> a -> Ordering
compare Word16
s2 Word16
s1
          descending_size EventParser a
_ EventParser a
_ = forall a. HasCallStack => a
undefined
          maybe_head :: [a] -> Maybe a
maybe_head [] = forall a. Maybe a
Nothing
          maybe_head (a
x:[a]
_) = forall a. a -> Maybe a
Just a
x

padParser :: EventTypeSize -> (EventParser a) -> (EventParser a)
padParser :: forall a. Word16 -> EventParser a -> EventParser a
padParser Word16
_    (VariableSizeParser Int
t Get a
p) = forall a. Int -> Get a -> EventParser a
VariableSizeParser Int
t Get a
p
padParser Word16
size (FixedSizeParser Int
t Word16
orig_size Get a
orig_p) = forall a. Int -> Word16 -> Get a -> EventParser a
FixedSizeParser Int
t Word16
size Get a
p
    where p :: Get a
p = if (Word16
size forall a. Eq a => a -> a -> Bool
== Word16
orig_size)
                then Get a
orig_p
                else do a
d <- Get a
orig_p
                        forall a. Integral a => a -> Get ()
skip (Word16
size forall a. Num a => a -> a -> a
- Word16
orig_size)
                        forall (m :: * -> *) a. Monad m => a -> m a
return a
d

makeParserMap :: [EventParser a] -> IntMap [EventParser a]
makeParserMap :: forall a. [EventParser a] -> IntMap [EventParser a]
makeParserMap = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {a}.
IntMap [EventParser a] -> EventParser a -> IntMap [EventParser a]
buildParserMap forall a. IntMap a
M.empty
    where buildParserMap :: IntMap [EventParser a] -> EventParser a -> IntMap [EventParser a]
buildParserMap IntMap [EventParser a]
map' EventParser a
parser =
              forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
M.alter (forall {a}. a -> Maybe [a] -> Maybe [a]
addParser EventParser a
parser) (forall a. EventParser a -> Int
getType EventParser a
parser) IntMap [EventParser a]
map'
          addParser :: a -> Maybe [a] -> Maybe [a]
addParser a
p Maybe [a]
Nothing = forall a. a -> Maybe a
Just [a
p]
          addParser a
p (Just [a]
ps) = forall a. a -> Maybe a
Just (a
pforall a. a -> [a] -> [a]
:[a]
ps)

noEventTypeParser :: Int -> Maybe EventTypeSize
                  -> Get EventInfo
noEventTypeParser :: Int -> Maybe Word16 -> Get EventInfo
noEventTypeParser Int
num Maybe Word16
mb_size = do
  Word16
bytes <- case Maybe Word16
mb_size of
             Just Word16
n  -> forall (m :: * -> *) a. Monad m => a -> m a
return Word16
n
             Maybe Word16
Nothing -> forall t. Binary t => Get t
get :: Get Word16
  forall a. Integral a => a -> Get ()
skip Word16
bytes
  forall (m :: * -> *) a. Monad m => a -> m a
return UnknownEvent{ ref :: Word16
ref = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
num }