{-# LANGUAGE OverloadedStrings #-}

{- | The NDJSON events a streaming test suite emits, as much of them as
@pbt-cli@ needs.

This is deliberately a *partial* view of @Convex.Tasty.Streaming.Types.Event@.
@pbt-cli@ has to keep working against suites built with an older or newer
@convex-tasty-streaming@ than the one it was compiled against, so every event
also keeps its raw 'Value' and any tag this module does not know about decodes
to 'EventOther' instead of failing. Only the fields the CLI actually renders or
makes decisions on are given names; @test_trace@ payloads, coverage indices,
threat-model summaries and QuickCheck monitoring stats are passed through
untouched.

The canonical, complete schema lives in
@src\/tasty-streaming\/schema\/streaming-events.schema.json@.
-}
module PbtCli.Events (
  -- * Events
  Event (..),
  TestInfo (..),
  Failure (..),
  eventTag,
  eventRaw,

  -- * Parsing a suite's stdout
  decodeEvent,
  isJsonObjectLine,
  jsonLines,
  eventsFrom,

  -- * Interpreting a run
  suiteOutcome,
  SuiteOutcome (..),
) where

import Data.Aeson (FromJSON (..), Value (..), eitherDecodeStrict', withObject, (.:), (.:?))
import Data.Aeson qualified as Aeson
import Data.Aeson.Types (parseEither)
import Data.ByteString.Char8 qualified as BS8
import Data.Maybe (mapMaybe)
import Data.Text (Text)

-- | One test in the tree, as reported by @suite_started@.
data TestInfo = TestInfo
  { TestInfo -> Int
tiId :: Int
  , TestInfo -> Text
tiName :: Text
  -- ^ the leaf label.
  , TestInfo -> [Text]
tiPath :: [Text]
  -- ^ group names from the root down to the test's parent.
  }
  deriving (TestInfo -> TestInfo -> Bool
(TestInfo -> TestInfo -> Bool)
-> (TestInfo -> TestInfo -> Bool) -> Eq TestInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestInfo -> TestInfo -> Bool
== :: TestInfo -> TestInfo -> Bool
$c/= :: TestInfo -> TestInfo -> Bool
/= :: TestInfo -> TestInfo -> Bool
Eq, Int -> TestInfo -> ShowS
[TestInfo] -> ShowS
TestInfo -> String
(Int -> TestInfo -> ShowS)
-> (TestInfo -> String) -> ([TestInfo] -> ShowS) -> Show TestInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestInfo -> ShowS
showsPrec :: Int -> TestInfo -> ShowS
$cshow :: TestInfo -> String
show :: TestInfo -> String
$cshowList :: [TestInfo] -> ShowS
showList :: [TestInfo] -> ShowS
Show)

instance FromJSON TestInfo where
  parseJSON :: Value -> Parser TestInfo
parseJSON = String -> (Object -> Parser TestInfo) -> Value -> Parser TestInfo
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"TestInfo" ((Object -> Parser TestInfo) -> Value -> Parser TestInfo)
-> (Object -> Parser TestInfo) -> Value -> Parser TestInfo
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Int -> Text -> [Text] -> TestInfo
TestInfo (Int -> Text -> [Text] -> TestInfo)
-> Parser Int -> Parser (Text -> [Text] -> TestInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"id" Parser (Text -> [Text] -> TestInfo)
-> Parser Text -> Parser ([Text] -> TestInfo)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name" Parser ([Text] -> TestInfo) -> Parser [Text] -> Parser TestInfo
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser [Text]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"path"

-- | Why a test failed.
data Failure = Failure
  { Failure -> Text
failReason :: Text
  , Failure -> Text
failMessage :: Text
  }
  deriving (Failure -> Failure -> Bool
(Failure -> Failure -> Bool)
-> (Failure -> Failure -> Bool) -> Eq Failure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Failure -> Failure -> Bool
== :: Failure -> Failure -> Bool
$c/= :: Failure -> Failure -> Bool
/= :: Failure -> Failure -> Bool
Eq, Int -> Failure -> ShowS
[Failure] -> ShowS
Failure -> String
(Int -> Failure -> ShowS)
-> (Failure -> String) -> ([Failure] -> ShowS) -> Show Failure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Failure -> ShowS
showsPrec :: Int -> Failure -> ShowS
$cshow :: Failure -> String
show :: Failure -> String
$cshowList :: [Failure] -> ShowS
showList :: [Failure] -> ShowS
Show)

instance FromJSON Failure where
  parseJSON :: Value -> Parser Failure
parseJSON = String -> (Object -> Parser Failure) -> Value -> Parser Failure
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Failure" ((Object -> Parser Failure) -> Value -> Parser Failure)
-> (Object -> Parser Failure) -> Value -> Parser Failure
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Text -> Text -> Failure
Failure (Text -> Text -> Failure)
-> Parser Text -> Parser (Text -> Failure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"reason" Parser (Text -> Failure) -> Parser Text -> Parser Failure
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"message"

-- | A streaming event. Each constructor keeps the line's raw JSON.
data Event
  = {- | @suite_started@: the whole test tree, before anything runs. This is
    also the single event @--list-tests-json@ emits.
    -}
    EventSuiteStarted
      { Event -> [TestInfo]
evTests :: [TestInfo]
      , Event -> Value
evSource :: Value
      }
  | -- | @test_started@
    EventTestStarted
      { Event -> Int
evId :: Int
      , evSource :: Value
      }
  | -- | @test_done@
    EventTestDone
      { evId :: Int
      , Event -> Bool
evSuccess :: Bool
      , Event -> Double
evDuration :: Double
      , Event -> Text
evDescription :: Text
      , Event -> Maybe Failure
evFailure :: Maybe Failure
      , evSource :: Value
      }
  | -- | @suite_done@
    EventSuiteDone
      { Event -> Int
evPassed :: Int
      , Event -> Int
evFailed :: Int
      , evDuration :: Double
      , evSource :: Value
      }
  | {- | any other tag — @test_progress@, @test_trace@, or something added to
    the library after this binary was built.
    -}
    EventOther
      { Event -> Text
evOtherTag :: Text
      , evSource :: Value
      }
  deriving (Event -> Event -> Bool
(Event -> Event -> Bool) -> (Event -> Event -> Bool) -> Eq Event
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Event -> Event -> Bool
== :: Event -> Event -> Bool
$c/= :: Event -> Event -> Bool
/= :: Event -> Event -> Bool
Eq, Int -> Event -> ShowS
[Event] -> ShowS
Event -> String
(Int -> Event -> ShowS)
-> (Event -> String) -> ([Event] -> ShowS) -> Show Event
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Event -> ShowS
showsPrec :: Int -> Event -> ShowS
$cshow :: Event -> String
show :: Event -> String
$cshowList :: [Event] -> ShowS
showList :: [Event] -> ShowS
Show)

instance FromJSON Event where
  parseJSON :: Value -> Parser Event
parseJSON Value
v = String -> (Object -> Parser Event) -> Value -> Parser Event
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Event" Object -> Parser Event
go Value
v
   where
    go :: Object -> Parser Event
go Object
o = do
      Text
tag :: Text <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"event"
      case Text
tag of
        Text
"suite_started" -> [TestInfo] -> Value -> Event
EventSuiteStarted ([TestInfo] -> Value -> Event)
-> Parser [TestInfo] -> Parser (Value -> Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser [TestInfo]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"tests" Parser (Value -> Event) -> Parser Value -> Parser Event
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser Value
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
        Text
"test_started" -> Int -> Value -> Event
EventTestStarted (Int -> Value -> Event) -> Parser Int -> Parser (Value -> Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"id" Parser (Value -> Event) -> Parser Value -> Parser Event
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser Value
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
        Text
"test_done" -> do
          Int
i <- Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"id"
          Bool
ok <- Object
o Object -> Key -> Parser Bool
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"success"
          Double
dur <- Object
o Object -> Key -> Parser Double
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"duration"
          Text
desc <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"description"
          Maybe Failure
fl <- if Bool
ok then Maybe Failure -> Parser (Maybe Failure)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Failure
forall a. Maybe a
Nothing else Object
o Object -> Key -> Parser (Maybe Failure)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"failure"
          Event -> Parser Event
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Bool -> Double -> Text -> Maybe Failure -> Value -> Event
EventTestDone Int
i Bool
ok Double
dur Text
desc Maybe Failure
fl Value
v)
        Text
"suite_done" ->
          Int -> Int -> Double -> Value -> Event
EventSuiteDone (Int -> Int -> Double -> Value -> Event)
-> Parser Int -> Parser (Int -> Double -> Value -> Event)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"passed" Parser (Int -> Double -> Value -> Event)
-> Parser Int -> Parser (Double -> Value -> Event)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"failed" Parser (Double -> Value -> Event)
-> Parser Double -> Parser (Value -> Event)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Double
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"duration" Parser (Value -> Event) -> Parser Value -> Parser Event
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser Value
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
        Text
other -> Event -> Parser Event
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Value -> Event
EventOther Text
other Value
v)

-- | The event's @event@ tag.
eventTag :: Event -> Text
eventTag :: Event -> Text
eventTag = \case
  EventSuiteStarted{} -> Text
"suite_started"
  EventTestStarted{} -> Text
"test_started"
  EventTestDone{} -> Text
"test_done"
  EventSuiteDone{} -> Text
"suite_done"
  EventOther Text
t Value
_ -> Text
t

-- | The event's original JSON, for pass-through output.
eventRaw :: Event -> Value
eventRaw :: Event -> Value
eventRaw = Event -> Value
evSource

{- | Decode one line as an event.

'Left' covers both "not JSON at all" (cabal's own chatter) and "JSON, but not
a recognisable event", which the caller normally wants to treat the same way:
ignore it.
-}
decodeEvent :: BS8.ByteString -> Either String Event
decodeEvent :: ByteString -> Either String Event
decodeEvent ByteString
line = do
  Value
v <- ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict' ByteString
line
  (Value -> Parser Event) -> Value -> Either String Event
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser Event
forall a. FromJSON a => Value -> Parser a
parseJSON (Value
v :: Value)

{- | Keep only the lines of a suite's stdout that are JSON objects.

@cabal test@ interleaves its own output — @Resolving dependencies@,
@Running 1 test suites...@, build progress — with the suite's NDJSON. This is
the equivalent of the @jq -R 'fromjson? // empty'@ idiom the tasty-streaming
README recommends, and for the same reason: there is no way to ask cabal to
stop talking, so the consumer filters.
-}
jsonLines :: [BS8.ByteString] -> [BS8.ByteString]
jsonLines :: [ByteString] -> [ByteString]
jsonLines = (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter ByteString -> Bool
isJsonObjectLine

{- | Is this single line a JSON object?

The cheap @{@ check comes first so cabal's chatter is rejected without paying
for a parse attempt on every build-progress line.
-}
isJsonObjectLine :: BS8.ByteString -> Bool
isJsonObjectLine :: ByteString -> Bool
isJsonObjectLine ByteString
l =
  case ByteString -> Maybe (Char, ByteString)
BS8.uncons ((Char -> Bool) -> ByteString -> ByteString
BS8.dropWhile (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
" \t" :: String)) ByteString
l) of
    Just (Char
'{', ByteString
_) -> case ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decodeStrict' ByteString
l :: Maybe Value of
      Just (Object Object
_) -> Bool
True
      Maybe Value
_ -> Bool
False
    Maybe (Char, ByteString)
_ -> Bool
False

-- | Every decodable event in a suite's stdout, in order.
eventsFrom :: [BS8.ByteString] -> [Event]
eventsFrom :: [ByteString] -> [Event]
eventsFrom = (ByteString -> Maybe Event) -> [ByteString] -> [Event]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((String -> Maybe Event)
-> (Event -> Maybe Event) -> Either String Event -> Maybe Event
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Event -> String -> Maybe Event
forall a b. a -> b -> a
const Maybe Event
forall a. Maybe a
Nothing) Event -> Maybe Event
forall a. a -> Maybe a
Just (Either String Event -> Maybe Event)
-> (ByteString -> Either String Event) -> ByteString -> Maybe Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String Event
decodeEvent) ([ByteString] -> [Event])
-> ([ByteString] -> [ByteString]) -> [ByteString] -> [Event]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> [ByteString]
jsonLines

-- | What a completed run amounted to.
data SuiteOutcome = SuiteOutcome
  { SuiteOutcome -> Int
outPassed :: Int
  , SuiteOutcome -> Int
outFailed :: Int
  , SuiteOutcome -> Double
outDuration :: Double
  }
  deriving (SuiteOutcome -> SuiteOutcome -> Bool
(SuiteOutcome -> SuiteOutcome -> Bool)
-> (SuiteOutcome -> SuiteOutcome -> Bool) -> Eq SuiteOutcome
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SuiteOutcome -> SuiteOutcome -> Bool
== :: SuiteOutcome -> SuiteOutcome -> Bool
$c/= :: SuiteOutcome -> SuiteOutcome -> Bool
/= :: SuiteOutcome -> SuiteOutcome -> Bool
Eq, Int -> SuiteOutcome -> ShowS
[SuiteOutcome] -> ShowS
SuiteOutcome -> String
(Int -> SuiteOutcome -> ShowS)
-> (SuiteOutcome -> String)
-> ([SuiteOutcome] -> ShowS)
-> Show SuiteOutcome
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SuiteOutcome -> ShowS
showsPrec :: Int -> SuiteOutcome -> ShowS
$cshow :: SuiteOutcome -> String
show :: SuiteOutcome -> String
$cshowList :: [SuiteOutcome] -> ShowS
showList :: [SuiteOutcome] -> ShowS
Show)

{- | The run's @suite_done@ tally, if the suite got that far.

'Nothing' means the suite never reported a summary — it crashed, was killed, or
was not a streaming suite at all — which is why callers must not treat a
missing summary as success.
-}
suiteOutcome :: [Event] -> Maybe SuiteOutcome
suiteOutcome :: [Event] -> Maybe SuiteOutcome
suiteOutcome [Event]
evs = case [Event
e | e :: Event
e@EventSuiteDone{} <- [Event]
evs] of
  [] -> Maybe SuiteOutcome
forall a. Maybe a
Nothing
  (Event
e : [Event]
_) -> SuiteOutcome -> Maybe SuiteOutcome
forall a. a -> Maybe a
Just (Int -> Int -> Double -> SuiteOutcome
SuiteOutcome (Event -> Int
evPassed Event
e) (Event -> Int
evFailed Event
e) (Event -> Double
evDuration Event
e))