module Convex.TestingInterface.Options (
  ThreatModelNameFilter (..),
  threatModelNameFilterIngredient,
  ListThreatModels (..),
  listThreatModelsIngredient,
  ListThreatModelsJson (..),
  listThreatModelsJsonIngredient,
  testingInterfaceIngredients,
  defaultMainTestingInterface,
) where

import Convex.Tasty.Streaming (defaultMainStreamingWithIngredients)
import Convex.ThreatModel.All (allThreatModelsNames)
import Data.Aeson ((.=))
import Data.Aeson qualified as Aeson
import Data.Aeson.Key qualified as Key
import Data.ByteString.Lazy.Char8 qualified as LBS
import Data.Proxy (Proxy (..))
import Data.Tagged (Tagged (..))
import Data.Typeable (Typeable)
import GHC.Stack (HasCallStack, withFrozenCallStack)
import System.Exit (exitSuccess)
import System.IO (BufferMode (..), hSetBuffering, stdout)
import Test.Tasty (TestTree)
import Test.Tasty.Ingredients (Ingredient (..))
import Test.Tasty.Options (IsOption (..), OptionDescription (Option), lookupOption, mkFlagCLParser, safeRead)

newtype ThreatModelNameFilter = ThreatModelNameFilter [String]
  deriving (ThreatModelNameFilter -> ThreatModelNameFilter -> Bool
(ThreatModelNameFilter -> ThreatModelNameFilter -> Bool)
-> (ThreatModelNameFilter -> ThreatModelNameFilter -> Bool)
-> Eq ThreatModelNameFilter
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ThreatModelNameFilter -> ThreatModelNameFilter -> Bool
== :: ThreatModelNameFilter -> ThreatModelNameFilter -> Bool
$c/= :: ThreatModelNameFilter -> ThreatModelNameFilter -> Bool
/= :: ThreatModelNameFilter -> ThreatModelNameFilter -> Bool
Eq, Eq ThreatModelNameFilter
Eq ThreatModelNameFilter =>
(ThreatModelNameFilter -> ThreatModelNameFilter -> Ordering)
-> (ThreatModelNameFilter -> ThreatModelNameFilter -> Bool)
-> (ThreatModelNameFilter -> ThreatModelNameFilter -> Bool)
-> (ThreatModelNameFilter -> ThreatModelNameFilter -> Bool)
-> (ThreatModelNameFilter -> ThreatModelNameFilter -> Bool)
-> (ThreatModelNameFilter
    -> ThreatModelNameFilter -> ThreatModelNameFilter)
-> (ThreatModelNameFilter
    -> ThreatModelNameFilter -> ThreatModelNameFilter)
-> Ord ThreatModelNameFilter
ThreatModelNameFilter -> ThreatModelNameFilter -> Bool
ThreatModelNameFilter -> ThreatModelNameFilter -> Ordering
ThreatModelNameFilter
-> ThreatModelNameFilter -> ThreatModelNameFilter
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 :: ThreatModelNameFilter -> ThreatModelNameFilter -> Ordering
compare :: ThreatModelNameFilter -> ThreatModelNameFilter -> Ordering
$c< :: ThreatModelNameFilter -> ThreatModelNameFilter -> Bool
< :: ThreatModelNameFilter -> ThreatModelNameFilter -> Bool
$c<= :: ThreatModelNameFilter -> ThreatModelNameFilter -> Bool
<= :: ThreatModelNameFilter -> ThreatModelNameFilter -> Bool
$c> :: ThreatModelNameFilter -> ThreatModelNameFilter -> Bool
> :: ThreatModelNameFilter -> ThreatModelNameFilter -> Bool
$c>= :: ThreatModelNameFilter -> ThreatModelNameFilter -> Bool
>= :: ThreatModelNameFilter -> ThreatModelNameFilter -> Bool
$cmax :: ThreatModelNameFilter
-> ThreatModelNameFilter -> ThreatModelNameFilter
max :: ThreatModelNameFilter
-> ThreatModelNameFilter -> ThreatModelNameFilter
$cmin :: ThreatModelNameFilter
-> ThreatModelNameFilter -> ThreatModelNameFilter
min :: ThreatModelNameFilter
-> ThreatModelNameFilter -> ThreatModelNameFilter
Ord, Typeable)

instance Monoid ThreatModelNameFilter where
  mempty :: ThreatModelNameFilter
mempty = [String] -> ThreatModelNameFilter
ThreatModelNameFilter []

instance Semigroup ThreatModelNameFilter where
  ThreatModelNameFilter [String]
a <> :: ThreatModelNameFilter
-> ThreatModelNameFilter -> ThreatModelNameFilter
<> ThreatModelNameFilter [String]
b = [String] -> ThreatModelNameFilter
ThreatModelNameFilter ([String]
a [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
b)

instance IsOption ThreatModelNameFilter where
  defaultValue :: ThreatModelNameFilter
defaultValue = [String] -> ThreatModelNameFilter
ThreatModelNameFilter []
  parseValue :: String -> Maybe ThreatModelNameFilter
parseValue String
raw = ThreatModelNameFilter -> Maybe ThreatModelNameFilter
forall a. a -> Maybe a
Just ([String] -> ThreatModelNameFilter
ThreatModelNameFilter (String -> [String]
parseThreatModelNames String
raw))
   where
    parseThreatModelNames :: String -> [String]
parseThreatModelNames String
s =
      case String
s of
        String
"" -> []
        String
_ -> (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
trim (Char -> String -> [String]
forall {t}. Eq t => t -> [t] -> [[t]]
splitOn Char
',' String
s)
    splitOn :: t -> [t] -> [[t]]
splitOn t
delim [t]
s = case (t -> Bool) -> [t] -> ([t], [t])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
delim) [t]
s of
      ([t]
a, []) -> [[t]
a]
      ([t]
a, t
_ : [t]
rest) -> [t]
a [t] -> [[t]] -> [[t]]
forall a. a -> [a] -> [a]
: t -> [t] -> [[t]]
splitOn t
delim [t]
rest
    trim :: String -> String
trim = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse
  optionName :: Tagged ThreatModelNameFilter String
optionName = String -> Tagged ThreatModelNameFilter String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"threat-model-name"
  optionHelp :: Tagged ThreatModelNameFilter String
optionHelp = String -> Tagged ThreatModelNameFilter String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"Run only threat models whose names start with these values (comma-separated for multiple; case-sensitive); expected vulnerabilities are unaffected"

threatModelNameFilterIngredient :: Ingredient
threatModelNameFilterIngredient :: Ingredient
threatModelNameFilterIngredient =
  [OptionDescription]
-> (OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient
TestManager
    [Proxy ThreatModelNameFilter -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy ThreatModelNameFilter
forall {k} (t :: k). Proxy t
Proxy :: Proxy ThreatModelNameFilter)]
    (\OptionSet
_ TestTree
_ -> Maybe (IO Bool)
forall a. Maybe a
Nothing)

newtype ListThreatModels = ListThreatModels Bool
  deriving (ListThreatModels -> ListThreatModels -> Bool
(ListThreatModels -> ListThreatModels -> Bool)
-> (ListThreatModels -> ListThreatModels -> Bool)
-> Eq ListThreatModels
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ListThreatModels -> ListThreatModels -> Bool
== :: ListThreatModels -> ListThreatModels -> Bool
$c/= :: ListThreatModels -> ListThreatModels -> Bool
/= :: ListThreatModels -> ListThreatModels -> Bool
Eq, Eq ListThreatModels
Eq ListThreatModels =>
(ListThreatModels -> ListThreatModels -> Ordering)
-> (ListThreatModels -> ListThreatModels -> Bool)
-> (ListThreatModels -> ListThreatModels -> Bool)
-> (ListThreatModels -> ListThreatModels -> Bool)
-> (ListThreatModels -> ListThreatModels -> Bool)
-> (ListThreatModels -> ListThreatModels -> ListThreatModels)
-> (ListThreatModels -> ListThreatModels -> ListThreatModels)
-> Ord ListThreatModels
ListThreatModels -> ListThreatModels -> Bool
ListThreatModels -> ListThreatModels -> Ordering
ListThreatModels -> ListThreatModels -> ListThreatModels
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 :: ListThreatModels -> ListThreatModels -> Ordering
compare :: ListThreatModels -> ListThreatModels -> Ordering
$c< :: ListThreatModels -> ListThreatModels -> Bool
< :: ListThreatModels -> ListThreatModels -> Bool
$c<= :: ListThreatModels -> ListThreatModels -> Bool
<= :: ListThreatModels -> ListThreatModels -> Bool
$c> :: ListThreatModels -> ListThreatModels -> Bool
> :: ListThreatModels -> ListThreatModels -> Bool
$c>= :: ListThreatModels -> ListThreatModels -> Bool
>= :: ListThreatModels -> ListThreatModels -> Bool
$cmax :: ListThreatModels -> ListThreatModels -> ListThreatModels
max :: ListThreatModels -> ListThreatModels -> ListThreatModels
$cmin :: ListThreatModels -> ListThreatModels -> ListThreatModels
min :: ListThreatModels -> ListThreatModels -> ListThreatModels
Ord, Typeable)

instance IsOption ListThreatModels where
  defaultValue :: ListThreatModels
defaultValue = Bool -> ListThreatModels
ListThreatModels Bool
False
  parseValue :: String -> Maybe ListThreatModels
parseValue = ListThreatModels -> Maybe ListThreatModels
forall a. a -> Maybe a
Just (ListThreatModels -> Maybe ListThreatModels)
-> (String -> ListThreatModels) -> String -> Maybe ListThreatModels
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ListThreatModels
ListThreatModels (Bool -> ListThreatModels)
-> (String -> Bool) -> String -> ListThreatModels
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"True")
  optionName :: Tagged ListThreatModels String
optionName = String -> Tagged ListThreatModels String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"list-threat-models"
  optionHelp :: Tagged ListThreatModels String
optionHelp = String -> Tagged ListThreatModels String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"List all available threat models and exit (does not run tests)"
  optionCLParser :: Parser ListThreatModels
optionCLParser = Mod FlagFields ListThreatModels
-> ListThreatModels -> Parser ListThreatModels
forall v. IsOption v => Mod FlagFields v -> v -> Parser v
mkFlagCLParser Mod FlagFields ListThreatModels
forall a. Monoid a => a
mempty (Bool -> ListThreatModels
ListThreatModels Bool
True)

listThreatModelsIngredient :: Ingredient
listThreatModelsIngredient :: Ingredient
listThreatModelsIngredient =
  [OptionDescription]
-> (OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient
TestManager
    [Proxy ListThreatModels -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy ListThreatModels
forall {k} (t :: k). Proxy t
Proxy :: Proxy ListThreatModels)]
    ((OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient)
-> (OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient
forall a b. (a -> b) -> a -> b
$ \OptionSet
opts TestTree
_ ->
      let ListThreatModels Bool
shouldList = OptionSet -> ListThreatModels
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
       in if Bool -> Bool
not Bool
shouldList
            then Maybe (IO Bool)
forall a. Maybe a
Nothing
            else IO Bool -> Maybe (IO Bool)
forall a. a -> Maybe a
Just (IO Bool -> Maybe (IO Bool)) -> IO Bool -> Maybe (IO Bool)
forall a b. (a -> b) -> a -> b
$ do
              (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
putStrLn [String]
allThreatModelsNames
              IO Bool
forall a. IO a
exitSuccess

newtype ListThreatModelsJson = ListThreatModelsJson Bool
  deriving (ListThreatModelsJson -> ListThreatModelsJson -> Bool
(ListThreatModelsJson -> ListThreatModelsJson -> Bool)
-> (ListThreatModelsJson -> ListThreatModelsJson -> Bool)
-> Eq ListThreatModelsJson
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ListThreatModelsJson -> ListThreatModelsJson -> Bool
== :: ListThreatModelsJson -> ListThreatModelsJson -> Bool
$c/= :: ListThreatModelsJson -> ListThreatModelsJson -> Bool
/= :: ListThreatModelsJson -> ListThreatModelsJson -> Bool
Eq, Eq ListThreatModelsJson
Eq ListThreatModelsJson =>
(ListThreatModelsJson -> ListThreatModelsJson -> Ordering)
-> (ListThreatModelsJson -> ListThreatModelsJson -> Bool)
-> (ListThreatModelsJson -> ListThreatModelsJson -> Bool)
-> (ListThreatModelsJson -> ListThreatModelsJson -> Bool)
-> (ListThreatModelsJson -> ListThreatModelsJson -> Bool)
-> (ListThreatModelsJson
    -> ListThreatModelsJson -> ListThreatModelsJson)
-> (ListThreatModelsJson
    -> ListThreatModelsJson -> ListThreatModelsJson)
-> Ord ListThreatModelsJson
ListThreatModelsJson -> ListThreatModelsJson -> Bool
ListThreatModelsJson -> ListThreatModelsJson -> Ordering
ListThreatModelsJson
-> ListThreatModelsJson -> ListThreatModelsJson
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 :: ListThreatModelsJson -> ListThreatModelsJson -> Ordering
compare :: ListThreatModelsJson -> ListThreatModelsJson -> Ordering
$c< :: ListThreatModelsJson -> ListThreatModelsJson -> Bool
< :: ListThreatModelsJson -> ListThreatModelsJson -> Bool
$c<= :: ListThreatModelsJson -> ListThreatModelsJson -> Bool
<= :: ListThreatModelsJson -> ListThreatModelsJson -> Bool
$c> :: ListThreatModelsJson -> ListThreatModelsJson -> Bool
> :: ListThreatModelsJson -> ListThreatModelsJson -> Bool
$c>= :: ListThreatModelsJson -> ListThreatModelsJson -> Bool
>= :: ListThreatModelsJson -> ListThreatModelsJson -> Bool
$cmax :: ListThreatModelsJson
-> ListThreatModelsJson -> ListThreatModelsJson
max :: ListThreatModelsJson
-> ListThreatModelsJson -> ListThreatModelsJson
$cmin :: ListThreatModelsJson
-> ListThreatModelsJson -> ListThreatModelsJson
min :: ListThreatModelsJson
-> ListThreatModelsJson -> ListThreatModelsJson
Ord, Typeable)

instance IsOption ListThreatModelsJson where
  defaultValue :: ListThreatModelsJson
defaultValue = Bool -> ListThreatModelsJson
ListThreatModelsJson Bool
False
  parseValue :: String -> Maybe ListThreatModelsJson
parseValue = (Bool -> ListThreatModelsJson)
-> Maybe Bool -> Maybe ListThreatModelsJson
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> ListThreatModelsJson
ListThreatModelsJson (Maybe Bool -> Maybe ListThreatModelsJson)
-> (String -> Maybe Bool) -> String -> Maybe ListThreatModelsJson
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Bool
forall a. Read a => String -> Maybe a
safeRead
  optionName :: Tagged ListThreatModelsJson String
optionName = String -> Tagged ListThreatModelsJson String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"list-threat-models-json"
  optionHelp :: Tagged ListThreatModelsJson String
optionHelp = String -> Tagged ListThreatModelsJson String
forall {k} (s :: k) b. b -> Tagged s b
Tagged String
"List all available threat models as JSON and exit (does not run tests)"
  optionCLParser :: Parser ListThreatModelsJson
optionCLParser = Mod FlagFields ListThreatModelsJson
-> ListThreatModelsJson -> Parser ListThreatModelsJson
forall v. IsOption v => Mod FlagFields v -> v -> Parser v
mkFlagCLParser Mod FlagFields ListThreatModelsJson
forall a. Monoid a => a
mempty (Bool -> ListThreatModelsJson
ListThreatModelsJson Bool
True)

listThreatModelsJsonIngredient :: Ingredient
listThreatModelsJsonIngredient :: Ingredient
listThreatModelsJsonIngredient =
  [OptionDescription]
-> (OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient
TestManager
    [Proxy ListThreatModelsJson -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy ListThreatModelsJson
forall {k} (t :: k). Proxy t
Proxy :: Proxy ListThreatModelsJson)]
    ((OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient)
-> (OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient
forall a b. (a -> b) -> a -> b
$ \OptionSet
opts TestTree
_ ->
      let ListThreatModelsJson Bool
shouldList = OptionSet -> ListThreatModelsJson
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
       in if Bool -> Bool
not Bool
shouldList
            then Maybe (IO Bool)
forall a. Maybe a
Nothing
            else IO Bool -> Maybe (IO Bool)
forall a. a -> Maybe a
Just (IO Bool -> Maybe (IO Bool)) -> IO Bool -> Maybe (IO Bool)
forall a b. (a -> b) -> a -> b
$ do
              Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
LineBuffering
              ByteString -> IO ()
LBS.putStrLn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
Aeson.object [String -> Key
Key.fromString String
"threatModels" Key -> [String] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [String]
allThreatModelsNames]
              IO Bool
forall a. IO a
exitSuccess

-- | Common testing-interface ingredients to combine with streaming defaults.
testingInterfaceIngredients :: [Ingredient]
testingInterfaceIngredients :: [Ingredient]
testingInterfaceIngredients =
  [ Ingredient
listThreatModelsIngredient
  , Ingredient
listThreatModelsJsonIngredient
  , Ingredient
threatModelNameFilterIngredient
  ]

-- | Default test-suite entrypoint for testing-interface packages.
defaultMainTestingInterface :: (HasCallStack) => TestTree -> IO ()
defaultMainTestingInterface :: HasCallStack => TestTree -> IO ()
defaultMainTestingInterface =
  (HasCallStack => TestTree -> IO ()) -> TestTree -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => TestTree -> IO ()) -> TestTree -> IO ())
-> (HasCallStack => TestTree -> IO ()) -> TestTree -> IO ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => [Ingredient] -> TestTree -> IO ()
[Ingredient] -> TestTree -> IO ()
defaultMainStreamingWithIngredients [Ingredient]
testingInterfaceIngredients