{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}

module Convex.Tasty.Streaming.TMSummary (
  ThreatModelSummary (..),
  TMStore,
  TMRecorder (..),
  TMStoreOption (..),
  TraceRecorder (..),
  newTMStore,
  storeRecorder,
  lookupThreatModelSummary,
) where

import Data.Aeson (FromJSON (..), ToJSON (..), Value, object, withObject, (.:), (.=))
import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Tagged (Tagged (..))
import Data.Text (Text)
import GHC.Generics (Generic)
import Test.Tasty.Options (IsOption (..))

-- | Structured summary of a threat-model test case.
data ThreatModelSummary = ThreatModelSummary
  { ThreatModelSummary -> Text
tmsName :: !Text
  , ThreatModelSummary -> Int
tmsTested :: !Int
  , ThreatModelSummary -> Int
tmsTotal :: !Int
  , ThreatModelSummary -> Int
tmsPassed :: !Int
  , ThreatModelSummary -> Int
tmsFailed :: !Int
  , ThreatModelSummary -> Int
tmsSkipped :: !Int
  , ThreatModelSummary -> Int
tmsErrors :: !Int
  }
  deriving (Int -> ThreatModelSummary -> ShowS
[ThreatModelSummary] -> ShowS
ThreatModelSummary -> String
(Int -> ThreatModelSummary -> ShowS)
-> (ThreatModelSummary -> String)
-> ([ThreatModelSummary] -> ShowS)
-> Show ThreatModelSummary
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ThreatModelSummary -> ShowS
showsPrec :: Int -> ThreatModelSummary -> ShowS
$cshow :: ThreatModelSummary -> String
show :: ThreatModelSummary -> String
$cshowList :: [ThreatModelSummary] -> ShowS
showList :: [ThreatModelSummary] -> ShowS
Show, ThreatModelSummary -> ThreatModelSummary -> Bool
(ThreatModelSummary -> ThreatModelSummary -> Bool)
-> (ThreatModelSummary -> ThreatModelSummary -> Bool)
-> Eq ThreatModelSummary
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ThreatModelSummary -> ThreatModelSummary -> Bool
== :: ThreatModelSummary -> ThreatModelSummary -> Bool
$c/= :: ThreatModelSummary -> ThreatModelSummary -> Bool
/= :: ThreatModelSummary -> ThreatModelSummary -> Bool
Eq, (forall x. ThreatModelSummary -> Rep ThreatModelSummary x)
-> (forall x. Rep ThreatModelSummary x -> ThreatModelSummary)
-> Generic ThreatModelSummary
forall x. Rep ThreatModelSummary x -> ThreatModelSummary
forall x. ThreatModelSummary -> Rep ThreatModelSummary x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ThreatModelSummary -> Rep ThreatModelSummary x
from :: forall x. ThreatModelSummary -> Rep ThreatModelSummary x
$cto :: forall x. Rep ThreatModelSummary x -> ThreatModelSummary
to :: forall x. Rep ThreatModelSummary x -> ThreatModelSummary
Generic)

instance ToJSON ThreatModelSummary where
  toJSON :: ThreatModelSummary -> Value
toJSON ThreatModelSummary
s =
    [Pair] -> Value
object
      [ Key
"name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ThreatModelSummary -> Text
tmsName ThreatModelSummary
s
      , Key
"tested" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ThreatModelSummary -> Int
tmsTested ThreatModelSummary
s
      , Key
"total" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ThreatModelSummary -> Int
tmsTotal ThreatModelSummary
s
      , Key
"passed" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ThreatModelSummary -> Int
tmsPassed ThreatModelSummary
s
      , Key
"failed" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ThreatModelSummary -> Int
tmsFailed ThreatModelSummary
s
      , Key
"skipped" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ThreatModelSummary -> Int
tmsSkipped ThreatModelSummary
s
      , Key
"errors" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ThreatModelSummary -> Int
tmsErrors ThreatModelSummary
s
      ]

instance FromJSON ThreatModelSummary where
  parseJSON :: Value -> Parser ThreatModelSummary
parseJSON = String
-> (Object -> Parser ThreatModelSummary)
-> Value
-> Parser ThreatModelSummary
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ThreatModelSummary" ((Object -> Parser ThreatModelSummary)
 -> Value -> Parser ThreatModelSummary)
-> (Object -> Parser ThreatModelSummary)
-> Value
-> Parser ThreatModelSummary
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Text
-> Int -> Int -> Int -> Int -> Int -> Int -> ThreatModelSummary
ThreatModelSummary
      (Text
 -> Int -> Int -> Int -> Int -> Int -> Int -> ThreatModelSummary)
-> Parser Text
-> Parser
     (Int -> Int -> Int -> Int -> Int -> Int -> ThreatModelSummary)
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
"name"
      Parser
  (Int -> Int -> Int -> Int -> Int -> Int -> ThreatModelSummary)
-> Parser Int
-> Parser (Int -> Int -> Int -> Int -> Int -> ThreatModelSummary)
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
"tested"
      Parser (Int -> Int -> Int -> Int -> Int -> ThreatModelSummary)
-> Parser Int
-> Parser (Int -> Int -> Int -> Int -> ThreatModelSummary)
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
"total"
      Parser (Int -> Int -> Int -> Int -> ThreatModelSummary)
-> Parser Int -> Parser (Int -> Int -> Int -> ThreatModelSummary)
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
"passed"
      Parser (Int -> Int -> Int -> ThreatModelSummary)
-> Parser Int -> Parser (Int -> Int -> ThreatModelSummary)
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 (Int -> Int -> ThreatModelSummary)
-> Parser Int -> Parser (Int -> ThreatModelSummary)
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
"skipped"
      Parser (Int -> ThreatModelSummary)
-> Parser Int -> Parser ThreatModelSummary
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
"errors"

-- | Mutable storage for threat-model summaries, owned by the reporter.
newtype TMStore = TMStore (IORef (Map String ThreatModelSummary))

{- | A recorder closure passed to test bodies via Tasty's option system.
The default no-op makes summaries silently dropped when the streaming
reporter is not active.
-}
newtype TMRecorder = TMRecorder
  { TMRecorder -> String -> ThreatModelSummary -> IO ()
tmRecord :: String -> ThreatModelSummary -> IO ()
  }

{- | Internal option carrying the live store. Set by `defaultMainStreaming`
alongside the recorder so the reporter can read summaries back out.
-}
newtype TMStoreOption = TMStoreOption (Maybe TMStore)

instance IsOption TMRecorder where
  defaultValue :: TMRecorder
defaultValue = (String -> ThreatModelSummary -> IO ()) -> TMRecorder
TMRecorder (\String
_ ThreatModelSummary
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  parseValue :: String -> Maybe TMRecorder
parseValue = Maybe TMRecorder -> String -> Maybe TMRecorder
forall a b. a -> b -> a
const Maybe TMRecorder
forall a. Maybe a
Nothing
  optionName :: Tagged TMRecorder String
optionName = String -> Tagged TMRecorder String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"tm-recorder"
  optionHelp :: Tagged TMRecorder String
optionHelp = String -> Tagged TMRecorder String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"internal: threat-model summary recorder"

instance IsOption TMStoreOption where
  defaultValue :: TMStoreOption
defaultValue = Maybe TMStore -> TMStoreOption
TMStoreOption Maybe TMStore
forall a. Maybe a
Nothing
  parseValue :: String -> Maybe TMStoreOption
parseValue = Maybe TMStoreOption -> String -> Maybe TMStoreOption
forall a b. a -> b -> a
const Maybe TMStoreOption
forall a. Maybe a
Nothing
  optionName :: Tagged TMStoreOption String
optionName = String -> Tagged TMStoreOption String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"tm-store"
  optionHelp :: Tagged TMStoreOption String
optionHelp = String -> Tagged TMStoreOption String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"internal: threat-model summary store handle"

-- | Allocate fresh storage. Call once per reporter run.
newTMStore :: IO TMStore
newTMStore :: IO TMStore
newTMStore = IORef (Map String ThreatModelSummary) -> TMStore
TMStore (IORef (Map String ThreatModelSummary) -> TMStore)
-> IO (IORef (Map String ThreatModelSummary)) -> IO TMStore
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map String ThreatModelSummary
-> IO (IORef (Map String ThreatModelSummary))
forall a. a -> IO (IORef a)
newIORef Map String ThreatModelSummary
forall k a. Map k a
Map.empty

-- | Build a recorder that writes into the given store.
storeRecorder :: TMStore -> TMRecorder
storeRecorder :: TMStore -> TMRecorder
storeRecorder (TMStore IORef (Map String ThreatModelSummary)
ref) = (String -> ThreatModelSummary -> IO ()) -> TMRecorder
TMRecorder ((String -> ThreatModelSummary -> IO ()) -> TMRecorder)
-> (String -> ThreatModelSummary -> IO ()) -> TMRecorder
forall a b. (a -> b) -> a -> b
$ \String
key ThreatModelSummary
s ->
  IORef (Map String ThreatModelSummary)
-> (Map String ThreatModelSummary
    -> (Map String ThreatModelSummary, ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map String ThreatModelSummary)
ref ((Map String ThreatModelSummary
  -> (Map String ThreatModelSummary, ()))
 -> IO ())
-> (Map String ThreatModelSummary
    -> (Map String ThreatModelSummary, ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Map String ThreatModelSummary
m -> (String
-> ThreatModelSummary
-> Map String ThreatModelSummary
-> Map String ThreatModelSummary
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
key ThreatModelSummary
s Map String ThreatModelSummary
m, ())

-- | Look up a summary by key (does not delete).
lookupThreatModelSummary :: TMStore -> String -> IO (Maybe ThreatModelSummary)
lookupThreatModelSummary :: TMStore -> String -> IO (Maybe ThreatModelSummary)
lookupThreatModelSummary (TMStore IORef (Map String ThreatModelSummary)
ref) String
key =
  String -> Map String ThreatModelSummary -> Maybe ThreatModelSummary
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
key (Map String ThreatModelSummary -> Maybe ThreatModelSummary)
-> IO (Map String ThreatModelSummary)
-> IO (Maybe ThreatModelSummary)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map String ThreatModelSummary)
-> IO (Map String ThreatModelSummary)
forall a. IORef a -> IO a
readIORef IORef (Map String ThreatModelSummary)
ref

{- | Callback for recording iteration traces as pre-serialized JSON.
Arguments: group name, category ("positive"\/"negative"), pre-serialized trace JSON.
Default is a no-op (zero overhead when streaming is not active).

When 'trEnabled' returns 'True', test bodies use the expensive traced code
path (building 'IterationTrace' values with UTxO snapshots, transaction
summaries, and JSON serialisation).  When it returns 'False' (the 'IsOption'
default), the cheap 'runActions' path is used instead, avoiding all that
work.

'trEnabled' is an 'IO' action so that the decision can be deferred until the
streaming reporter has parsed @--no-trace@ and written the shared 'IORef'.
-}
data TraceRecorder = TraceRecorder
  { TraceRecorder -> IO Bool
trEnabled :: IO Bool
  -- ^ Whether test bodies should collect detailed traces.
  , TraceRecorder -> String -> String -> Value -> IO ()
recordIteration :: String -> String -> Value -> IO ()
  -- ^ Emit a single iteration trace event.
  }

instance IsOption TraceRecorder where
  defaultValue :: TraceRecorder
defaultValue = IO Bool -> (String -> String -> Value -> IO ()) -> TraceRecorder
TraceRecorder (Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) (\String
_ String
_ Value
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
  parseValue :: String -> Maybe TraceRecorder
parseValue = Maybe TraceRecorder -> String -> Maybe TraceRecorder
forall a b. a -> b -> a
const Maybe TraceRecorder
forall a. Maybe a
Nothing
  optionName :: Tagged TraceRecorder String
optionName = String -> Tagged TraceRecorder String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"trace-recorder"
  optionHelp :: Tagged TraceRecorder String
optionHelp = String -> Tagged TraceRecorder String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"internal: iteration trace recorder"