Internal.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA
{-# LANGUAGE InstanceSigs #-}

-- | This module is the internal implementation of "Test.Cleveland.Tasty".
module Test.Cleveland.Tasty.Internal
  (
  -- * Main
    clevelandMain
  , clevelandMainWithIngredients
  , clevelandIngredients
  , loadTastyEnv

  -- * Test cases
  , testScenario
  , testScenarioOnEmulator
  , testScenarioOnNetwork

  , whenNetworkEnabled

  -- * Reading/setting options
  , modifyNetworkEnv
  , setAliasPrefix

  -- * Internals
  , RunOnNetwork(..)
  , RunOnEmulator(..)
  , tastyEnvFromOpts
  , onNetworkTag
  , TastyEnvOpt(..)
  , TastyEnv(..)
  , mkTastyEnv
  , mapTastyEnv
  , memoize
  , loadOptionSwitcher
  ) where

import Control.Concurrent (modifyMVar, withMVar)
import Data.Char qualified as C
import Data.Tagged (Tagged(Tagged))
import Fmt (pretty)
import System.Environment (lookupEnv)
import System.IO.Unsafe qualified as Unsafe
import Test.Tasty
  (TestName, adjustOption, askOption, defaultIngredients, defaultMainWithIngredients,
  includingOptions, localOption, testGroup)
import Test.Tasty.Ingredients (Ingredient)
import Test.Tasty.Options (IsOption(..), OptionSet, lookupOption)
import Test.Tasty.Patterns.Types as Tasty (Expr(..))
import Test.Tasty.Providers (IsTest(..), Progress, singleTest, testFailed, testPassed)
import Test.Tasty.Runners (Result(..), TestPattern(..), TestTree(AskOptions))

import Morley.Client (MorleyClientConfig(..), mceTezosClientL, mkMorleyClientEnv)
import Morley.Client.TezosClient.Types (tceAliasPrefixL)
import Test.Cleveland.Internal.Client as Client
  (ClientM, NetworkEnv(..), neMorleyClientEnvL, runClevelandT)
import Test.Cleveland.Internal.Exceptions (WithCallStack(WithCallStack))
import Test.Cleveland.Internal.Pure as Pure (PureM, runClevelandT, runEmulatedT)
import Test.Cleveland.Internal.Scenario
import Test.Cleveland.Tasty.Internal.Options
  (AliasPrefixOpt(..), ContextLinesOpt(..), DataDirOpt(..), EndpointOpt(..), MoneybagAliasOpt(..),
  PathOpt(..), RunModeOpt(..), SecretKeyOpt(..), VerboseOpt(..), clevelandOptions)
import Test.Cleveland.Tasty.Internal.Report (formatError)

-- | A name that we use to tag all tests that run on the network.
--
-- We use this in a tasty @--pattern@ in .gitlab-ci.yml to run only network tests.
onNetworkTag :: TestName
onNetworkTag = "On network"

-- | Create a tasty test case from a 'Scenario'.
--
-- This will create a test tree with 2 tests:
-- one that runs the 'Scenario' on the "Morley.Michelson.Runtime" emulator,
-- and another that runs it on a real Tezos network.
--
-- The network config is read from the command line/environment variables.
-- Use @--help@ to see the available options.
--
-- If a 'TestTree' contains many tests scheduled to run on a real Tezos network,
-- those tests will be run sequentially.
testScenario :: TestName -> (forall m. MonadFail m => Scenario m) -> TestTree
testScenario testName scenario' =
  testGroup testName
    [ singleTest "On emulator" (RunOnEmulator scenario')
    , singleTest onNetworkTag (RunOnNetwork scenario')
    ]

-- | Create a tasty test case from an emulated 'Scenario'.
--
-- This will create a test tree with 1 test,
-- which will run the 'Scenario' on the "Morley.Michelson.Runtime" emulator.
testScenarioOnEmulator ::  TestName -> Scenario PureM -> TestTree
testScenarioOnEmulator testname scenario' =
  testGroup testname
    [ singleTest "On emulator" (RunOnEmulator scenario') ]

-- | Create a tasty test case from a 'Scenario'.
--
-- This will create a test tree with 1 test,
-- which will run the 'Scenario' on real Tezos network.
testScenarioOnNetwork ::  TestName -> Scenario ClientM -> TestTree
testScenarioOnNetwork testname scenario' =
  testGroup testname
    [ singleTest onNetworkTag (RunOnNetwork scenario') ]

newtype RunOnEmulator = RunOnEmulator (Scenario PureM)

instance IsTest RunOnEmulator where
  run :: OptionSet -> RunOnEmulator -> (Progress -> IO ()) -> IO Result
  run opts (RunOnEmulator scenario') _ = do
    let
      MoneybagAliasOpt moneybagAlias = lookupOption opts
      io = case scenario' of
              ScenarioCleveland s -> Pure.runClevelandT moneybagAlias s
              ScenarioEmulated s -> Pure.runEmulatedT moneybagAlias s
    (io $> testPassed "") `catch` printFormattedException opts

  testOptions = Tagged clevelandOptions

newtype RunOnNetwork = RunOnNetwork (Scenario ClientM)

instance IsTest RunOnNetwork where
  run :: OptionSet -> RunOnNetwork -> (Progress -> IO ()) -> IO Result
  run opts (RunOnNetwork (ScenarioCleveland clevelandT)) _ = do
    let
      tastyEnv = tastyEnvFromOpts opts
    useNetworkEnv tastyEnv $ \networkEnv -> do
      let io = Client.runClevelandT networkEnv clevelandT
      (io $> testPassed "") `catch` printFormattedException opts

  -- If a 'RunOnNetwork' test is created somewhere in a suite,
  -- these options will be automatically added to tasty's @--help@.
  testOptions = Tagged clevelandOptions

printFormattedException :: OptionSet -> SomeException -> IO Result
printFormattedException opts se =
  case fromException @WithCallStack se of
    Nothing ->
      pure (testFailed $ displayException se)

    Just (WithCallStack cs ex) -> do
      msg <- formatError contextLines cs (displayException ex)
      pure (testFailed (pretty msg))
  where
    ContextLinesOpt contextLines = lookupOption opts

-- | A global mutex to ensure only one cleveland test is executed at a time.
--
-- TODO [#399]: Remove this when is done.
-- https://gitlab.com/morley-framework/morley/-/issues/399
--
-- See also: https://wiki.haskell.org/Top_level_mutable_state
lock :: MVar ()
lock = Unsafe.unsafePerformIO (newMVar ())
{-# NOINLINE lock #-}

----------------------------------------------------------------------------
-- Main
----------------------------------------------------------------------------

-- | Similar to @tasty@ @defaultMain@, but also preloads 'TastyEnv' and
-- registers the necessary command line options/environment variables to configure
-- "Test.Cleveland".
clevelandMain :: TestTree -> IO ()
clevelandMain = clevelandMainWithIngredients defaultIngredients . loadTastyEnv

-- | Similar to 'defaultMainWithIngredients', but also preloads 'TastyEnv' and
-- registers the necessary command line options/environment variables to configure
-- "Test.Cleveland".
clevelandMainWithIngredients :: [Ingredient] -> TestTree -> IO ()
clevelandMainWithIngredients ingredients tree = do
  ciSwitch <- withinCI
  defaultMainWithIngredients
    (clevelandIngredients <> ingredients)
    (loadOptionSwitcher ciSwitch . loadTastyEnv $ tree)

-- | A list with all the ingredients necessary to configure "Test.Cleveland".
--
-- Note: If a test suite uses 'Scenario', the relevant command line options
-- will be automatically added to tasty's @--help@.
--
-- However, if a test suite intends to not use those functions, and use 'whenNetworkEnabled'
-- only, then the CLI options need to be registered manually by using this ingredient
-- (or 'clevelandMain'/'clevelandMainWithIngredients').
clevelandIngredients :: [Ingredient]
clevelandIngredients =
  [ includingOptions clevelandOptions
  ]

----------------------------------------------------------------------------
-- Reading/setting options
----------------------------------------------------------------------------

-- | Creates a 'TastyEnv' from the passed command line/environment options.
tastyEnvFromOpts :: OptionSet -> TastyEnv
tastyEnvFromOpts optionSet =
  let
    AliasPrefixOpt aliasPrefix = lookupOption optionSet
    EndpointOpt endpoint = lookupOption optionSet
    PathOpt path = lookupOption optionSet
    DataDirOpt dataDir = lookupOption optionSet
    VerboseOpt verbosity = lookupOption optionSet
    SecretKeyOpt sk = lookupOption optionSet
    MoneybagAliasOpt origAlias = lookupOption optionSet
  in
    case lookupOption @TastyEnvOpt optionSet of
      -- If 'TastyEnv' has been already loaded and cached, use it.
      TastyEnvOpt (Just tastyEnv) -> tastyEnv
      -- Otherwise, load it.
      TastyEnvOpt Nothing -> mkTastyEnv $ do
        morleyClientEnv <- mkMorleyClientEnv MorleyClientConfig
          { mccAliasPrefix = aliasPrefix
          , mccEndpointUrl = endpoint
          , mccTezosClientPath = path
          , mccMbTezosClientDataDir = dataDir
          , mccVerbosity = verbosity
          , mccSecretKey = Nothing
          }
        pure NetworkEnv
            { neMorleyClientEnv = morleyClientEnv
            , neSecretKey = sk
            , neMoneybagAlias = origAlias
            }

-- | Heuristics to check whether we are running within CI.
-- Check the respective env variable which is usually set in all CIs.
withinCI :: IO Bool
withinCI = lookupEnv "CI" <&> \case
  Just "1"                       -> True
  Just (map C.toLower -> "true") -> True
  _                              -> False
{-# NOINLINE withinCI #-}

-- | Runs some tests only when network tests are enabled
-- (i.e., when running in the CI or when @--cleveland-mode all@).
--
-- Do not use this with a cleveland test (e.g. with 'testScenario'), as it will
-- lead to a [deadlock](https://gitlab.com/morley-framework/morley/-/issues/728).
-- This is only suitable for HUnit/Hspec/Hedgehog/etc tests.
--
-- Example usage:
--
-- > test :: TestTree
-- > test =
-- >   whenNetworkEnabled $ \withEnv ->
-- >     testCase "a test name" $
-- >       withEnv $ \env ->
-- >         runMorleyClientM (neMorleyClientEnv env) $ do
-- >           ...
whenNetworkEnabled :: ((forall a. (NetworkEnv -> IO a) -> IO a) -> TestTree) -> TestTree
whenNetworkEnabled mkTestTree =
  AskOptions \optionSet ->
    let TastyEnv useNetworkEnv = tastyEnvFromOpts optionSet
      in testGroup onNetworkTag [ mkTestTree useNetworkEnv ]

-- | Modifies the 'NetworkEnv' for all the tests in the given test tree.
modifyNetworkEnv :: (NetworkEnv -> NetworkEnv) -> TestTree -> TestTree
modifyNetworkEnv f tree =
  AskOptions \optionSet ->
  let tastyEnv = tastyEnvFromOpts optionSet
    in localOption (TastyEnvOpt $ Just (mapTastyEnv f tastyEnv)) $
         tree

-- | Overrides the alias prefix (parsed from @--cleveland-alias-prefix@ or @TASTY_CLEVELAND_ALIAS_PREFIX@)
-- for all the tests in the given test tree.
setAliasPrefix :: Text -> TestTree -> TestTree
setAliasPrefix aliasPrefix tree =
  modifyNetworkEnv (neMorleyClientEnvL.mceTezosClientL.tceAliasPrefixL .~ Just aliasPrefix) $
    tree

----------------------------------------------------------------------------
-- Preload TastyEnv
----------------------------------------------------------------------------

-- | A pre-loaded 'TastyEnv'.
--
-- It's not an actual command line option, we use it
-- so we can load a 'TastyEnv' once, and then cache it
-- alongside the other options in tasty's 'OptionSet'.
--
-- Kiiiind of a hack, but it works :D
--
-- It is purposefully never registered as a CLI option
-- (e.g. using 'Test.Tasty.Providers.testOptions' or 'Test.Tasty.includingOptions')
-- to make sure it doesn't appear in tasty's @--help@.
newtype TastyEnvOpt = TastyEnvOpt (Maybe TastyEnv)

instance IsOption TastyEnvOpt where
  defaultValue = TastyEnvOpt Nothing
  optionName = ""
  optionHelp = ""
  parseValue = \_ -> Nothing

-- | Pre-load 'TastyEnv' from the passed command line/environment options,
-- and store it in tasty's 'OptionSet' to make it available to
-- all tests within the test tree.
--
-- Creating a 'NetworkEnv' is a relatively expensive operation, when executed hundreds of times.
-- This function guarantees that only one 'TastyEnv' is created for this test tree, and
-- 'TastyEnv' will, in turn, guarantee that only one 'NetworkEnv' is created while the tests are running.
loadTastyEnv :: TestTree -> TestTree
loadTastyEnv tree =
  AskOptions \optionSet ->
    let tastyEnv = tastyEnvFromOpts optionSet
    in localOption (TastyEnvOpt $ Just tastyEnv)
         tree

----------------------------------------------------------------------------
-- TastyEnv
----------------------------------------------------------------------------

-- | This action will:
--
-- 1. Enter a critical section
-- 2. Either:
--
--     * Create a 'NetworkEnv' and cache it, if it's the first time being evaluated.
--     * Or reuse an existing cached 'NetworkEnv' otherwise.
--
-- 3. Pass it to the given @networkEnv -> IO a@ function.
-- 4. Exit the critical section
--
-- This ensures:
--
-- * 'NetworkEnv' is only created once (it's a relatively expensive operation).
-- * tests that use 'NetworkEnv' are run sequentially
--    (see #399, https://gitlab.com/morley-framework/morley/-/issues/399)
newtype TastyEnv = TastyEnv
  { useNetworkEnv :: forall a. (NetworkEnv -> IO a) -> IO a
  }

mkTastyEnv :: IO NetworkEnv -> TastyEnv
mkTastyEnv mkEnv =
  TastyEnv
    { useNetworkEnv = \cont ->
        withMVar lock $ \() -> do
          env <- memoMkEnv
          cont env
    }
  where
    -- Note: Using `unsafePerformIO` here is the recommended workaround for
    -- not being able to use IO inside `askOption`/`AskOptions`.
    -- https://github.com/feuerbach/tasty/issues/228
    --
    -- We're only using it here to initialize an 'MVar', so it /should/ be safe 🤞
    memoMkEnv = Unsafe.unsafePerformIO $ memoize mkEnv

mapTastyEnv :: (NetworkEnv -> NetworkEnv) -> (TastyEnv -> TastyEnv)
mapTastyEnv g (TastyEnv f) =
  TastyEnv $ \cont ->
    f (\networkEnv -> cont (g networkEnv))

-- | A thread-safe, lazy, write-once cache.
--
-- >>> action <- memoize (putStrLn "hello" $> 3)
-- >>> action
-- hello
-- 3
-- >>> action
-- 3
memoize :: forall a. IO a -> IO (IO a)
memoize action = do
  -- The implementation is very similar to 'once' from @io-memoize@.
  -- https://hackage.haskell.org/package/io-memoize-1.1.1.0/docs/System-IO-Memoize.html
  cache <- newMVar Nothing

  let
    readCache :: IO a
    readCache =
      readMVar cache >>= \case
        Just a -> pure a
        Nothing ->
          modifyMVar cache $ \case
            Just a -> pure (Just a, a)
            Nothing -> do
              a <- action
              pure (Just a, a)

  pure readCache

----------------------------------------------------------------------------
-- Custom @TestPattern@s
----------------------------------------------------------------------------

-- | Helper that checks which environment variables / command line options are set,
-- and filters TestTree to run tests according to the decision table
-- at the top of this module.
loadOptionSwitcher :: Bool -> TestTree -> TestTree
loadOptionSwitcher ciFlag testTree =
  askOption @RunModeOpt $ \mode -> case (mode, ciFlag) of
    (RunAllMode, _) -> testTree
    (OnlyNetworkMode, _) -> loadOnlyNetworkPattern testTree
    (DisableNetworkMode, _) -> loadNoNetworkPattern testTree
    (DefaultMode, False) -> loadNoNetworkPattern testTree
    (DefaultMode, True) -> testTree
  where
     loadOnlyNetworkPattern :: TestTree -> TestTree
     loadOnlyNetworkPattern = adjustOption (adjustExprToTestPattern runOnlyNetworkExpr)

     loadNoNetworkPattern :: TestTree -> TestTree
     loadNoNetworkPattern = adjustOption (adjustExprToTestPattern dontRunNetworkExpr)

     adjustExprToTestPattern :: Expr -> TestPattern -> TestPattern
     adjustExprToTestPattern expr (TestPattern maybePattern) = TestPattern $ Just
       case maybePattern of
         Nothing -> expr
         Just ptrn -> And ptrn expr

-- | Pattern that enables only network tests, all emulator tests will be disabled.
--
-- Tasty pattern eDSL version of
-- "$1 == \"On network\" || $NF == \"On network\" || $0 ~ /.On network./"
runOnlyNetworkExpr :: Expr
runOnlyNetworkExpr =
  Or
    (Or
      (Tasty.EQ (Field (IntLit 1)) (StringLit "On network"))
      (Tasty.EQ (Field NF) (StringLit "On network"))
    )
    (Match (Field (IntLit 0)) ".On network.")

-- | Pattern that disables all network tests, all other tests will be enabled.
--
-- Tasty pattern eDSL version of
-- "$1 != \"On network\" && $NF != \"On network\" && $0 !~ /.On network./"
dontRunNetworkExpr :: Expr
dontRunNetworkExpr =
  And
    (And
      (Tasty.NE (Field (IntLit 1)) (StringLit "On network"))
      (Tasty.NE (Field NF) (StringLit "On network"))
    )
    (NoMatch (Field (IntLit 0)) ".On network.")