{-# 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 :: a -> Get String
getString a
len = do
  ByteString
bytes <- Int -> Get ByteString
G.getByteString (Int -> Get ByteString) -> Int -> Get ByteString
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
len
  String -> Get String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Get String) -> String -> Get String
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 :: a -> Get Text
getText a
len = do
  ByteString
bytes <- Int -> Get ByteString
G.getByteString (Int -> Get ByteString) -> Int -> Get ByteString
forall a b. (a -> b) -> a -> b
$ a -> Int
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 -> String -> Get Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get Text) -> String -> Get Text
forall a b. (a -> b) -> a -> b
$ UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
err
    Right Text
text -> Text -> Get 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 -> String -> Get Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get Text) -> String -> Get Text
forall a b. (a -> b) -> a -> b
$ UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
err
    Right Text
text -> Text -> Get Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Get Text) -> Text -> Get Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.toStrict Text
text

skip :: Integral a => a -> Get ()
skip :: a -> Get ()
skip a
n = Int -> Get ()
G.skip (a -> Int
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 vairable size.
--
data EventParser a
    = FixedSizeParser {
        EventParser a -> Int
fsp_type        :: Int,
        EventParser a -> EventTypeSize
fsp_size        :: EventTypeSize,
        EventParser a -> Get a
fsp_parser      :: Get a
    }
    | VariableSizeParser {
        EventParser a -> Int
vsp_type        :: Int,
        EventParser a -> Get a
vsp_parser      :: Get a
    }

getParser :: EventParser a -> Get a
getParser :: EventParser a -> Get a
getParser (FixedSizeParser Int
_ EventTypeSize
_ Get a
p) = Get a
p
getParser (VariableSizeParser Int
_ Get a
p) = Get a
p

getType :: EventParser a -> Int
getType :: EventParser a -> Int
getType (FixedSizeParser Int
t EventTypeSize
_ Get a
_) = Int
t
getType (VariableSizeParser Int
t Get a
_) = Int
t

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

simpleEvent :: Int -> a -> EventParser a
simpleEvent :: Int -> a -> EventParser a
simpleEvent Int
t a
p = Int -> EventTypeSize -> Get a -> EventParser a
forall a. Int -> EventTypeSize -> Get a -> EventParser a
FixedSizeParser Int
t EventTypeSize
0 (a -> Get a
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 earier 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
 = (Get EventInfo -> Get EventInfo -> Get EventInfo)
-> Get EventInfo
-> (Int, Int)
-> [(Int, Get EventInfo)]
-> Array Int (Get EventInfo)
forall i e a.
Ix i =>
(e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
accumArray ((Get EventInfo -> Get EventInfo -> Get EventInfo)
-> Get EventInfo -> Get EventInfo -> Get EventInfo
forall a b c. (a -> b -> c) -> b -> a -> c
flip Get EventInfo -> Get EventInfo -> Get EventInfo
forall a b. a -> b -> a
const) Get EventInfo
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 = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (IntMap EventType -> [Int]
forall a. IntMap a -> [Int]
M.keys IntMap EventType
etypes)
    undeclared_etype :: a -> m a
undeclared_etype a
num = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"undeclared event type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
num)
    parser_map :: IntMap [EventParser EventInfo]
parser_map = [EventParser EventInfo] -> IntMap [EventParser EventInfo]
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 EventTypeSize)
mb_mb_et_size = do EventType
et <- Int -> IntMap EventType -> Maybe EventType
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
num IntMap EventType
etypes
                               Maybe EventTypeSize -> Maybe (Maybe EventTypeSize)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe EventTypeSize -> Maybe (Maybe EventTypeSize))
-> Maybe EventTypeSize -> Maybe (Maybe EventTypeSize)
forall a b. (a -> b) -> a -> b
$ EventType -> Maybe EventTypeSize
size EventType
et
            -- Find a parser for the event with the given size.
            maybe_parser :: Maybe EventTypeSize -> Maybe (Get EventInfo)
maybe_parser Maybe EventTypeSize
mb_et_size = do [EventParser EventInfo]
possible <- Int
-> IntMap [EventParser EventInfo] -> Maybe [EventParser EventInfo]
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
num IntMap [EventParser EventInfo]
parser_map
                                         EventParser EventInfo
best_parser <- case Maybe EventTypeSize
mb_et_size of
                                            Maybe EventTypeSize
Nothing -> [EventParser EventInfo] -> Maybe (EventParser EventInfo)
forall a. [EventParser a] -> Maybe (EventParser a)
getVariableParser [EventParser EventInfo]
possible
                                            Just EventTypeSize
et_size -> EventTypeSize
-> [EventParser EventInfo] -> Maybe (EventParser EventInfo)
forall a. EventTypeSize -> [EventParser a] -> Maybe (EventParser a)
getFixedParser EventTypeSize
et_size [EventParser EventInfo]
possible
                                         Get EventInfo -> Maybe (Get EventInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Get EventInfo -> Maybe (Get EventInfo))
-> Get EventInfo -> Maybe (Get EventInfo)
forall a b. (a -> b) -> a -> b
$ EventParser EventInfo -> Get EventInfo
forall a. EventParser a -> Get a
getParser EventParser EventInfo
best_parser
            in case Maybe (Maybe EventTypeSize)
mb_mb_et_size of
                -- This event is declared in the log file's header
                Just Maybe EventTypeSize
mb_et_size -> case Maybe EventTypeSize -> Maybe (Get EventInfo)
maybe_parser Maybe EventTypeSize
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 EventTypeSize -> Get EventInfo
noEventTypeParser Int
num Maybe EventTypeSize
mb_et_size
                -- This event is not declared in the log file's header
                Maybe (Maybe EventTypeSize)
Nothing -> Int -> Get EventInfo
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 :: [EventParser a] -> Maybe (EventParser a)
getVariableParser [] = Maybe (EventParser a)
forall a. Maybe a
Nothing
getVariableParser (EventParser a
x:[EventParser a]
xs) = case EventParser a
x of
    FixedSizeParser Int
_ EventTypeSize
_ Get a
_ -> [EventParser a] -> Maybe (EventParser a)
forall a. [EventParser a] -> Maybe (EventParser a)
getVariableParser [EventParser a]
xs
    VariableSizeParser Int
_ Get a
_ -> EventParser a -> Maybe (EventParser 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 :: EventTypeSize -> [EventParser a] -> Maybe (EventParser a)
getFixedParser EventTypeSize
size [EventParser a]
parsers =
        do EventParser a
parser <- (((EventParser a -> Bool) -> [EventParser a] -> [EventParser a]
forall a. (a -> Bool) -> [a] -> [a]
filter EventParser a -> Bool
forall a. EventParser a -> Bool
isFixedSize) ([EventParser a] -> [EventParser a])
-> ([EventParser a] -> [EventParser a])
-> [EventParser a]
-> [EventParser a]
forall a b c. (a -> b) -> (b -> c) -> a -> c
`pipe`
                      ((EventParser a -> Bool) -> [EventParser a] -> [EventParser a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\EventParser a
x -> (EventParser a -> EventTypeSize
forall a. EventParser a -> EventTypeSize
fsp_size EventParser a
x) EventTypeSize -> EventTypeSize -> Bool
forall a. Ord a => a -> a -> Bool
<= EventTypeSize
size)) ([EventParser a] -> [EventParser a])
-> ([EventParser a] -> [EventParser a])
-> [EventParser a]
-> [EventParser a]
forall a b c. (a -> b) -> (b -> c) -> a -> c
`pipe`
                      ((EventParser a -> EventParser a -> Ordering)
-> [EventParser a] -> [EventParser a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy EventParser a -> EventParser a -> Ordering
forall a a. EventParser a -> EventParser a -> Ordering
descending_size) ([EventParser a] -> [EventParser a])
-> ([EventParser a] -> Maybe (EventParser a))
-> [EventParser a]
-> Maybe (EventParser a)
forall a b c. (a -> b) -> (b -> c) -> a -> c
`pipe`
                      [EventParser a] -> Maybe (EventParser a)
forall a. [a] -> Maybe a
maybe_head) [EventParser a]
parsers
           EventParser a -> Maybe (EventParser a)
forall (m :: * -> *) a. Monad m => a -> m a
return (EventParser a -> Maybe (EventParser a))
-> EventParser a -> Maybe (EventParser a)
forall a b. (a -> b) -> a -> b
$ EventTypeSize -> EventParser a -> EventParser a
forall a. EventTypeSize -> EventParser a -> EventParser a
padParser EventTypeSize
size EventParser a
parser
    where pipe :: (a -> b) -> (b -> c) -> a -> c
pipe a -> b
f b -> c
g = b -> c
g (b -> c) -> (a -> b) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f
          descending_size :: EventParser a -> EventParser a -> Ordering
descending_size (FixedSizeParser Int
_ EventTypeSize
s1 Get a
_) (FixedSizeParser Int
_ EventTypeSize
s2 Get a
_) =
            EventTypeSize -> EventTypeSize -> Ordering
forall a. Ord a => a -> a -> Ordering
compare EventTypeSize
s2 EventTypeSize
s1
          descending_size EventParser a
_ EventParser a
_ = Ordering
forall a. HasCallStack => a
undefined
          maybe_head :: [a] -> Maybe a
maybe_head [] = Maybe a
forall a. Maybe a
Nothing
          maybe_head (a
x:[a]
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
x

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

makeParserMap :: [EventParser a] -> IntMap [EventParser a]
makeParserMap :: [EventParser a] -> IntMap [EventParser a]
makeParserMap = (IntMap [EventParser a] -> EventParser a -> IntMap [EventParser a])
-> IntMap [EventParser a]
-> [EventParser a]
-> IntMap [EventParser a]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl IntMap [EventParser a] -> EventParser a -> IntMap [EventParser a]
forall a.
IntMap [EventParser a] -> EventParser a -> IntMap [EventParser a]
buildParserMap IntMap [EventParser a]
forall a. IntMap a
M.empty
    where buildParserMap :: IntMap [EventParser a] -> EventParser a -> IntMap [EventParser a]
buildParserMap IntMap [EventParser a]
map' EventParser a
parser =
              (Maybe [EventParser a] -> Maybe [EventParser a])
-> Int -> IntMap [EventParser a] -> IntMap [EventParser a]
forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
M.alter (EventParser a -> Maybe [EventParser a] -> Maybe [EventParser a]
forall a. a -> Maybe [a] -> Maybe [a]
addParser EventParser a
parser) (EventParser a -> Int
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 = [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a
p]
          addParser a
p (Just [a]
ps) = [a] -> Maybe [a]
forall a. a -> Maybe a
Just (a
pa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ps)

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