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

module Convex.Tasty.Streaming.TMSummary (
  ThreatModelSummary (..),
  ThreatModelCategory (..),
  Fault (..),
  faultLabel,
  threatModelGroupName,
  TMStore,
  TMRecorder (..),
  TMStoreOption (..),
  TraceRecorder (..),
  CoverageIndexStorage (..),
  newTMStore,
  storeRecorder,
  lookupThreatModelSummary,
) where

import Convex.Tasty.Streaming.SrcLoc (SrcLocRange)
import Data.Aeson (FromJSON (..), ToJSON (..), Value, object, withObject, withText, (.:), (.:?), (.=))
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 (..))

{- | Which list of a suite's @ThreatModelsFor@ instance a threat model was run
from. It decides how the counts in a 'ThreatModelSummary' are to be read: the
same 'tmsFailed' (the attack's mutated transaction still validated) is a
vulnerability for a 'Claimed' model, the required outcome for an 'Expected'
one, and a known, tolerated artifact for an 'Accepted' one. A consumer that
alerts on @failed > 0@ must therefore filter on the category first.
-}
data ThreatModelCategory
  = -- | From @threatModels@: the contract is claimed secure against it; a detection fails the test.
    Claimed
  | -- | From @expectedVulnerabilities@: the contract is known vulnerable; no detection fails the test.
    Expected
  | -- | From @acceptedFindings@: the finding is a known benign artifact. Judged like @Expected@ - a detection is the required outcome.
    Accepted
  | -- | From @candidateModels@: run for information. Reported, but never failed for not applying.
    Surveyed
  | -- | From @notApplicable@: reviewed as not applying here; it applying at all fails the test.
    NotApplicable
  deriving (Int -> ThreatModelCategory -> ShowS
[ThreatModelCategory] -> ShowS
ThreatModelCategory -> String
(Int -> ThreatModelCategory -> ShowS)
-> (ThreatModelCategory -> String)
-> ([ThreatModelCategory] -> ShowS)
-> Show ThreatModelCategory
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ThreatModelCategory -> ShowS
showsPrec :: Int -> ThreatModelCategory -> ShowS
$cshow :: ThreatModelCategory -> String
show :: ThreatModelCategory -> String
$cshowList :: [ThreatModelCategory] -> ShowS
showList :: [ThreatModelCategory] -> ShowS
Show, ThreatModelCategory -> ThreatModelCategory -> Bool
(ThreatModelCategory -> ThreatModelCategory -> Bool)
-> (ThreatModelCategory -> ThreatModelCategory -> Bool)
-> Eq ThreatModelCategory
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ThreatModelCategory -> ThreatModelCategory -> Bool
== :: ThreatModelCategory -> ThreatModelCategory -> Bool
$c/= :: ThreatModelCategory -> ThreatModelCategory -> Bool
/= :: ThreatModelCategory -> ThreatModelCategory -> Bool
Eq, Eq ThreatModelCategory
Eq ThreatModelCategory =>
(ThreatModelCategory -> ThreatModelCategory -> Ordering)
-> (ThreatModelCategory -> ThreatModelCategory -> Bool)
-> (ThreatModelCategory -> ThreatModelCategory -> Bool)
-> (ThreatModelCategory -> ThreatModelCategory -> Bool)
-> (ThreatModelCategory -> ThreatModelCategory -> Bool)
-> (ThreatModelCategory
    -> ThreatModelCategory -> ThreatModelCategory)
-> (ThreatModelCategory
    -> ThreatModelCategory -> ThreatModelCategory)
-> Ord ThreatModelCategory
ThreatModelCategory -> ThreatModelCategory -> Bool
ThreatModelCategory -> ThreatModelCategory -> Ordering
ThreatModelCategory -> ThreatModelCategory -> ThreatModelCategory
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ThreatModelCategory -> ThreatModelCategory -> Ordering
compare :: ThreatModelCategory -> ThreatModelCategory -> Ordering
$c< :: ThreatModelCategory -> ThreatModelCategory -> Bool
< :: ThreatModelCategory -> ThreatModelCategory -> Bool
$c<= :: ThreatModelCategory -> ThreatModelCategory -> Bool
<= :: ThreatModelCategory -> ThreatModelCategory -> Bool
$c> :: ThreatModelCategory -> ThreatModelCategory -> Bool
> :: ThreatModelCategory -> ThreatModelCategory -> Bool
$c>= :: ThreatModelCategory -> ThreatModelCategory -> Bool
>= :: ThreatModelCategory -> ThreatModelCategory -> Bool
$cmax :: ThreatModelCategory -> ThreatModelCategory -> ThreatModelCategory
max :: ThreatModelCategory -> ThreatModelCategory -> ThreatModelCategory
$cmin :: ThreatModelCategory -> ThreatModelCategory -> ThreatModelCategory
min :: ThreatModelCategory -> ThreatModelCategory -> ThreatModelCategory
Ord, Int -> ThreatModelCategory
ThreatModelCategory -> Int
ThreatModelCategory -> [ThreatModelCategory]
ThreatModelCategory -> ThreatModelCategory
ThreatModelCategory -> ThreatModelCategory -> [ThreatModelCategory]
ThreatModelCategory
-> ThreatModelCategory
-> ThreatModelCategory
-> [ThreatModelCategory]
(ThreatModelCategory -> ThreatModelCategory)
-> (ThreatModelCategory -> ThreatModelCategory)
-> (Int -> ThreatModelCategory)
-> (ThreatModelCategory -> Int)
-> (ThreatModelCategory -> [ThreatModelCategory])
-> (ThreatModelCategory
    -> ThreatModelCategory -> [ThreatModelCategory])
-> (ThreatModelCategory
    -> ThreatModelCategory -> [ThreatModelCategory])
-> (ThreatModelCategory
    -> ThreatModelCategory
    -> ThreatModelCategory
    -> [ThreatModelCategory])
-> Enum ThreatModelCategory
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: ThreatModelCategory -> ThreatModelCategory
succ :: ThreatModelCategory -> ThreatModelCategory
$cpred :: ThreatModelCategory -> ThreatModelCategory
pred :: ThreatModelCategory -> ThreatModelCategory
$ctoEnum :: Int -> ThreatModelCategory
toEnum :: Int -> ThreatModelCategory
$cfromEnum :: ThreatModelCategory -> Int
fromEnum :: ThreatModelCategory -> Int
$cenumFrom :: ThreatModelCategory -> [ThreatModelCategory]
enumFrom :: ThreatModelCategory -> [ThreatModelCategory]
$cenumFromThen :: ThreatModelCategory -> ThreatModelCategory -> [ThreatModelCategory]
enumFromThen :: ThreatModelCategory -> ThreatModelCategory -> [ThreatModelCategory]
$cenumFromTo :: ThreatModelCategory -> ThreatModelCategory -> [ThreatModelCategory]
enumFromTo :: ThreatModelCategory -> ThreatModelCategory -> [ThreatModelCategory]
$cenumFromThenTo :: ThreatModelCategory
-> ThreatModelCategory
-> ThreatModelCategory
-> [ThreatModelCategory]
enumFromThenTo :: ThreatModelCategory
-> ThreatModelCategory
-> ThreatModelCategory
-> [ThreatModelCategory]
Enum, ThreatModelCategory
ThreatModelCategory
-> ThreatModelCategory -> Bounded ThreatModelCategory
forall a. a -> a -> Bounded a
$cminBound :: ThreatModelCategory
minBound :: ThreatModelCategory
$cmaxBound :: ThreatModelCategory
maxBound :: ThreatModelCategory
Bounded, (forall x. ThreatModelCategory -> Rep ThreatModelCategory x)
-> (forall x. Rep ThreatModelCategory x -> ThreatModelCategory)
-> Generic ThreatModelCategory
forall x. Rep ThreatModelCategory x -> ThreatModelCategory
forall x. ThreatModelCategory -> Rep ThreatModelCategory x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ThreatModelCategory -> Rep ThreatModelCategory x
from :: forall x. ThreatModelCategory -> Rep ThreatModelCategory x
$cto :: forall x. Rep ThreatModelCategory x -> ThreatModelCategory
to :: forall x. Rep ThreatModelCategory x -> ThreatModelCategory
Generic)

instance ToJSON ThreatModelCategory where
  toJSON :: ThreatModelCategory -> Value
toJSON = \case
    ThreatModelCategory
Claimed -> Value
"claimed"
    ThreatModelCategory
Expected -> Value
"expected"
    ThreatModelCategory
Accepted -> Value
"accepted"
    ThreatModelCategory
Surveyed -> Value
"surveyed"
    ThreatModelCategory
NotApplicable -> Value
"not_applicable"

instance FromJSON ThreatModelCategory where
  parseJSON :: Value -> Parser ThreatModelCategory
parseJSON = String
-> (Text -> Parser ThreatModelCategory)
-> Value
-> Parser ThreatModelCategory
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"ThreatModelCategory" ((Text -> Parser ThreatModelCategory)
 -> Value -> Parser ThreatModelCategory)
-> (Text -> Parser ThreatModelCategory)
-> Value
-> Parser ThreatModelCategory
forall a b. (a -> b) -> a -> b
$ \case
    Text
"claimed" -> ThreatModelCategory -> Parser ThreatModelCategory
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ThreatModelCategory
Claimed
    Text
"expected" -> ThreatModelCategory -> Parser ThreatModelCategory
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ThreatModelCategory
Expected
    Text
"accepted" -> ThreatModelCategory -> Parser ThreatModelCategory
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ThreatModelCategory
Accepted
    Text
"surveyed" -> ThreatModelCategory -> Parser ThreatModelCategory
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ThreatModelCategory
Surveyed
    Text
"not_applicable" -> ThreatModelCategory -> Parser ThreatModelCategory
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ThreatModelCategory
NotApplicable
    Text
other -> String -> Parser ThreatModelCategory
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unknown threat model category: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
other)

{- | The Tasty group that a category's per-model test cases live under. The
single source of both the group the test tree is built with and the names the
streaming reporter matches on, so that a category cannot end up in a group the
reporter does not recognise (@--test-id@ resolves a per-model test's
@Positive tests@ prerequisite from these names).
-}
threatModelGroupName :: ThreatModelCategory -> String
threatModelGroupName :: ThreatModelCategory -> String
threatModelGroupName = \case
  ThreatModelCategory
Claimed -> String
"Threat models"
  ThreatModelCategory
Surveyed -> String
"Surveyed threat models"
  ThreatModelCategory
NotApplicable -> String
"Not applicable"
  ThreatModelCategory
Expected -> String
"Expected vulnerabilities"
  ThreatModelCategory
Accepted -> String
"Accepted findings"

{- | Whose fault a failing threat-model test case is.

Only one cell of the slot-by-outcome matrix is the contract's fault; most
red is a stale declaration. Saying which lets a reader — or a dashboard —
tell "the contract regressed" from "somebody needs to update the instance",
and stops a resolved vulnerability from reading as a broken contract.
-}
data Fault
  = -- | The script is at fault: fix the contract.
    Contract
  | -- | The @ThreatModelsFor@ instance is stale or wrong: edit the declaration.
    Declaration
  | -- | The attack could not be carried out: fix the generator, or accept a harness limit.
    Setup
  deriving (Int -> Fault -> ShowS
[Fault] -> ShowS
Fault -> String
(Int -> Fault -> ShowS)
-> (Fault -> String) -> ([Fault] -> ShowS) -> Show Fault
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Fault -> ShowS
showsPrec :: Int -> Fault -> ShowS
$cshow :: Fault -> String
show :: Fault -> String
$cshowList :: [Fault] -> ShowS
showList :: [Fault] -> ShowS
Show, Fault -> Fault -> Bool
(Fault -> Fault -> Bool) -> (Fault -> Fault -> Bool) -> Eq Fault
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Fault -> Fault -> Bool
== :: Fault -> Fault -> Bool
$c/= :: Fault -> Fault -> Bool
/= :: Fault -> Fault -> Bool
Eq, Eq Fault
Eq Fault =>
(Fault -> Fault -> Ordering)
-> (Fault -> Fault -> Bool)
-> (Fault -> Fault -> Bool)
-> (Fault -> Fault -> Bool)
-> (Fault -> Fault -> Bool)
-> (Fault -> Fault -> Fault)
-> (Fault -> Fault -> Fault)
-> Ord Fault
Fault -> Fault -> Bool
Fault -> Fault -> Ordering
Fault -> Fault -> Fault
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Fault -> Fault -> Ordering
compare :: Fault -> Fault -> Ordering
$c< :: Fault -> Fault -> Bool
< :: Fault -> Fault -> Bool
$c<= :: Fault -> Fault -> Bool
<= :: Fault -> Fault -> Bool
$c> :: Fault -> Fault -> Bool
> :: Fault -> Fault -> Bool
$c>= :: Fault -> Fault -> Bool
>= :: Fault -> Fault -> Bool
$cmax :: Fault -> Fault -> Fault
max :: Fault -> Fault -> Fault
$cmin :: Fault -> Fault -> Fault
min :: Fault -> Fault -> Fault
Ord, Int -> Fault
Fault -> Int
Fault -> [Fault]
Fault -> Fault
Fault -> Fault -> [Fault]
Fault -> Fault -> Fault -> [Fault]
(Fault -> Fault)
-> (Fault -> Fault)
-> (Int -> Fault)
-> (Fault -> Int)
-> (Fault -> [Fault])
-> (Fault -> Fault -> [Fault])
-> (Fault -> Fault -> [Fault])
-> (Fault -> Fault -> Fault -> [Fault])
-> Enum Fault
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Fault -> Fault
succ :: Fault -> Fault
$cpred :: Fault -> Fault
pred :: Fault -> Fault
$ctoEnum :: Int -> Fault
toEnum :: Int -> Fault
$cfromEnum :: Fault -> Int
fromEnum :: Fault -> Int
$cenumFrom :: Fault -> [Fault]
enumFrom :: Fault -> [Fault]
$cenumFromThen :: Fault -> Fault -> [Fault]
enumFromThen :: Fault -> Fault -> [Fault]
$cenumFromTo :: Fault -> Fault -> [Fault]
enumFromTo :: Fault -> Fault -> [Fault]
$cenumFromThenTo :: Fault -> Fault -> Fault -> [Fault]
enumFromThenTo :: Fault -> Fault -> Fault -> [Fault]
Enum, Fault
Fault -> Fault -> Bounded Fault
forall a. a -> a -> Bounded a
$cminBound :: Fault
minBound :: Fault
$cmaxBound :: Fault
maxBound :: Fault
Bounded, (forall x. Fault -> Rep Fault x)
-> (forall x. Rep Fault x -> Fault) -> Generic Fault
forall x. Rep Fault x -> Fault
forall x. Fault -> Rep Fault x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Fault -> Rep Fault x
from :: forall x. Fault -> Rep Fault x
$cto :: forall x. Rep Fault x -> Fault
to :: forall x. Rep Fault x -> Fault
Generic)

instance ToJSON Fault where
  toJSON :: Fault -> Value
toJSON = \case
    Fault
Contract -> Value
"contract"
    Fault
Declaration -> Value
"declaration"
    Fault
Setup -> Value
"setup"

instance FromJSON Fault where
  parseJSON :: Value -> Parser Fault
parseJSON = String -> (Text -> Parser Fault) -> Value -> Parser Fault
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Fault" ((Text -> Parser Fault) -> Value -> Parser Fault)
-> (Text -> Parser Fault) -> Value -> Parser Fault
forall a b. (a -> b) -> a -> b
$ \case
    Text
"contract" -> Fault -> Parser Fault
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Fault
Contract
    Text
"declaration" -> Fault -> Parser Fault
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Fault
Declaration
    Text
"setup" -> Fault -> Parser Fault
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Fault
Setup
    Text
other -> String -> Parser Fault
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unknown fault: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
other)

-- | The prefix a failure message leads with, so the fault is greppable.
faultLabel :: Fault -> String
faultLabel :: Fault -> String
faultLabel = \case
  Fault
Contract -> String
"CONTRACT"
  Fault
Declaration -> String
"DECLARATION"
  Fault
Setup -> String
"SETUP"

-- | Structured summary of a threat-model test case.
data ThreatModelSummary = ThreatModelSummary
  { ThreatModelSummary -> Text
tmsName :: !Text
  , ThreatModelSummary -> ThreatModelCategory
tmsCategory :: !ThreatModelCategory
  , ThreatModelSummary -> Int
tmsTested :: !Int
  , ThreatModelSummary -> Int
tmsTotal :: !Int
  , ThreatModelSummary -> Int
tmsPassed :: !Int
  , ThreatModelSummary -> Int
tmsFailed :: !Int
  , ThreatModelSummary -> Int
tmsSkipped :: !Int
  , ThreatModelSummary -> Int
tmsSkippedPhase1 :: !Int
  , ThreatModelSummary -> Int
tmsErrors :: !Int
  , ThreatModelSummary -> Maybe Fault
tmsFault :: !(Maybe Fault)
  -- ^ Set only when the case failed, saying whose fault it is.
  }
  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
"category" Key -> ThreatModelCategory -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ThreatModelSummary -> ThreatModelCategory
tmsCategory 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
"skipped_phase1" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ThreatModelSummary -> Int
tmsSkippedPhase1 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
      , Key
"fault" Key -> Maybe Fault -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ThreatModelSummary -> Maybe Fault
tmsFault 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
-> ThreatModelCategory
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Int
-> Maybe Fault
-> ThreatModelSummary
ThreatModelSummary
      (Text
 -> ThreatModelCategory
 -> Int
 -> Int
 -> Int
 -> Int
 -> Int
 -> Int
 -> Int
 -> Maybe Fault
 -> ThreatModelSummary)
-> Parser Text
-> Parser
     (ThreatModelCategory
      -> Int
      -> Int
      -> Int
      -> Int
      -> Int
      -> Int
      -> Int
      -> Maybe Fault
      -> 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"
      -- Required, as in the schema: defaulting a missing category to 'Claimed'
      -- would decode an accepted finding with @failed > 0@ as a vulnerability.
      Parser
  (ThreatModelCategory
   -> Int
   -> Int
   -> Int
   -> Int
   -> Int
   -> Int
   -> Int
   -> Maybe Fault
   -> ThreatModelSummary)
-> Parser ThreatModelCategory
-> Parser
     (Int
      -> Int
      -> Int
      -> Int
      -> Int
      -> Int
      -> Int
      -> Maybe Fault
      -> 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 ThreatModelCategory
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"category"
      Parser
  (Int
   -> Int
   -> Int
   -> Int
   -> Int
   -> Int
   -> Int
   -> Maybe Fault
   -> ThreatModelSummary)
-> Parser Int
-> Parser
     (Int
      -> Int
      -> Int
      -> Int
      -> Int
      -> Int
      -> Maybe Fault
      -> 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
   -> Int
   -> Maybe Fault
   -> ThreatModelSummary)
-> Parser Int
-> Parser
     (Int
      -> Int -> Int -> Int -> Int -> Maybe Fault -> 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 -> Int -> Maybe Fault -> ThreatModelSummary)
-> Parser Int
-> Parser
     (Int -> Int -> Int -> Int -> Maybe Fault -> 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 -> Int -> Maybe Fault -> ThreatModelSummary)
-> Parser Int
-> Parser (Int -> Int -> Int -> Maybe Fault -> 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 -> Int -> Maybe Fault -> ThreatModelSummary)
-> Parser Int
-> Parser (Int -> Int -> Maybe Fault -> 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 -> Int -> Maybe Fault -> ThreatModelSummary)
-> Parser Int -> Parser (Int -> Maybe Fault -> 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_phase1"
      Parser (Int -> Maybe Fault -> ThreatModelSummary)
-> Parser Int -> Parser (Maybe Fault -> 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"
      -- Optional: only a failing case has a fault.
      Parser (Maybe Fault -> ThreatModelSummary)
-> Parser (Maybe Fault) -> 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 (Maybe Fault)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"fault"

-- | 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 -> [SrcLocRange] -> Value -> IO ()
recordIteration :: String -> String -> [SrcLocRange] -> Value -> IO ()
  -- ^ Emit a single iteration trace event.
  , TraceRecorder -> String -> String -> IO (Maybe Int)
findTestIdIO :: String -> String -> IO (Maybe Int)
  }

instance IsOption TraceRecorder where
  defaultValue :: TraceRecorder
defaultValue = IO Bool
-> (String -> String -> [SrcLocRange] -> Value -> IO ())
-> (String -> String -> IO (Maybe Int))
-> TraceRecorder
TraceRecorder (Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) (\String
_ String
_ [SrcLocRange]
_ Value
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (\String
_ String
_ -> Maybe Int -> IO (Maybe Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing)
  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"

-- | Internal option carrying the coverage index, i.e. all the possible code range that can be reported as covered.
newtype CoverageIndexStorage = CoverageIndexStorage {CoverageIndexStorage -> [SrcLocRange]
getCoverageIndex :: [SrcLocRange]}

instance IsOption CoverageIndexStorage where
  defaultValue :: CoverageIndexStorage
defaultValue = [SrcLocRange] -> CoverageIndexStorage
CoverageIndexStorage []
  parseValue :: String -> Maybe CoverageIndexStorage
parseValue = Maybe CoverageIndexStorage -> String -> Maybe CoverageIndexStorage
forall a b. a -> b -> a
const Maybe CoverageIndexStorage
forall a. Maybe a
Nothing
  optionName :: Tagged CoverageIndexStorage String
optionName = String -> Tagged CoverageIndexStorage String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"coverage-index-storage"
  optionHelp :: Tagged CoverageIndexStorage String
optionHelp = String -> Tagged CoverageIndexStorage String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"internal: coverage index storage"