-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# OPTIONS_HADDOCK not-home #-}

-- | This module is the internal implementation of "Test.Cleveland.Tasty".
module Test.Cleveland.Tasty.Internal
  ( module Test.Cleveland.Tasty.Internal
  ) where

import Control.Concurrent (modifyMVar, withMVar)
import Data.Char qualified as C
import Data.Tagged (Tagged(Tagged))
import Fmt (pretty)
import System.Directory (removeDirectoryRecursive)
import System.Environment (lookupEnv)
import System.IO.Temp (createTempDirectory, getCanonicalTemporaryDirectory)
import System.IO.Unsafe qualified as Unsafe
import Test.Tasty
  (TestName, adjustOption, askOption, defaultIngredients, defaultMainWithIngredients,
  includingOptions, localOption, testGroup, withResource)
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 (tceMbTezosClientDataDirL)
import Test.Cleveland.Internal.Abstract (NetworkEnv(..), neMorleyClientEnvL)
import Test.Cleveland.Internal.Client as Client (ClientM, runNetworkT)
import Test.Cleveland.Internal.Exceptions
import Test.Cleveland.Internal.Pure as Pure (PureM, runEmulatedT)
import Test.Cleveland.Internal.Scenario
import Test.Cleveland.Tasty.Internal.Options
  (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 :: String
onNetworkTag = String
"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. Scenario m) -> TestTree
testScenario :: String -> (forall (m :: * -> *). Scenario m) -> TestTree
testScenario String
testName forall (m :: * -> *). Scenario m
scenario_ =
  String -> [TestTree] -> TestTree
testGroup String
testName
    [ String -> RunOnEmulator -> TestTree
forall t. IsTest t => String -> t -> TestTree
singleTest String
"On emulator" (Scenario PureM -> RunOnEmulator
RunOnEmulator Scenario PureM
forall (m :: * -> *). Scenario m
scenario_)
    , String -> RunOnNetwork -> TestTree
forall t. IsTest t => String -> t -> TestTree
singleTest String
onNetworkTag (Scenario ClientM -> RunOnNetwork
RunOnNetwork Scenario ClientM
forall (m :: * -> *). Scenario m
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 :: String -> Scenario PureM -> TestTree
testScenarioOnEmulator String
testname Scenario PureM
scenario_ =
  String -> [TestTree] -> TestTree
testGroup String
testname
    [ String -> RunOnEmulator -> TestTree
forall t. IsTest t => String -> t -> TestTree
singleTest String
"On emulator" (Scenario PureM -> RunOnEmulator
RunOnEmulator Scenario PureM
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 :: String -> Scenario ClientM -> TestTree
testScenarioOnNetwork String
testname Scenario ClientM
scenario_ =
  String -> [TestTree] -> TestTree
testGroup String
testname
    [ String -> RunOnNetwork -> TestTree
forall t. IsTest t => String -> t -> TestTree
singleTest String
onNetworkTag (Scenario ClientM -> RunOnNetwork
RunOnNetwork Scenario ClientM
scenario_) ]

newtype RunOnEmulator = RunOnEmulator (Scenario PureM)

instance IsTest RunOnEmulator where
  run :: OptionSet -> RunOnEmulator -> (Progress -> IO ()) -> IO Result
  run :: OptionSet -> RunOnEmulator -> (Progress -> IO ()) -> IO Result
run OptionSet
opts (RunOnEmulator (ScenarioEmulated EmulatedT PureM ()
emulatedT)) Progress -> IO ()
_ = do
    let
      MoneybagAliasOpt ImplicitAlias
moneybagAlias = OptionSet -> MoneybagAliasOpt
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
      io :: IO ()
io = ImplicitAlias -> EmulatedT PureM () -> IO ()
forall a. ImplicitAlias -> EmulatedT PureM a -> IO a
Pure.runEmulatedT ImplicitAlias
moneybagAlias EmulatedT PureM ()
emulatedT
    (IO ()
io IO () -> Result -> IO Result
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> String -> Result
testPassed String
"") IO Result -> (SomeException -> IO Result) -> IO Result
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` OptionSet -> SomeException -> IO Result
printFormattedException OptionSet
opts

  testOptions :: Tagged RunOnEmulator [OptionDescription]
testOptions = [OptionDescription] -> Tagged RunOnEmulator [OptionDescription]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [OptionDescription]
clevelandOptions

newtype RunOnNetwork = RunOnNetwork (Scenario ClientM)

instance IsTest RunOnNetwork where
  run :: OptionSet -> RunOnNetwork -> (Progress -> IO ()) -> IO Result
  run :: OptionSet -> RunOnNetwork -> (Progress -> IO ()) -> IO Result
run OptionSet
opts (RunOnNetwork (ScenarioNetwork NetworkT ClientM ()
clevelandT)) Progress -> IO ()
_ = do
    let
      tastyEnv :: TastyEnv
tastyEnv = OptionSet -> TastyEnv
tastyEnvFromOpts OptionSet
opts
    TastyEnv -> forall a. (NetworkEnv -> IO a) -> IO a
useNetworkEnv TastyEnv
tastyEnv ((NetworkEnv -> IO Result) -> IO Result)
-> (NetworkEnv -> IO Result) -> IO Result
forall a b. (a -> b) -> a -> b
$ \NetworkEnv
networkEnv -> do
      let io :: IO ()
io = NetworkEnv -> NetworkT ClientM () -> IO ()
forall a. NetworkEnv -> NetworkT ClientM a -> IO a
Client.runNetworkT NetworkEnv
networkEnv NetworkT ClientM ()
clevelandT
      (IO ()
io IO () -> Result -> IO Result
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> String -> Result
testPassed String
"") IO Result -> (SomeException -> IO Result) -> IO Result
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` OptionSet -> SomeException -> IO Result
printFormattedException OptionSet
opts

  -- If a 'RunOnNetwork' test is created somewhere in a suite,
  -- these options will be automatically added to tasty's @--help@.
  testOptions :: Tagged RunOnNetwork [OptionDescription]
testOptions = [OptionDescription] -> Tagged RunOnNetwork [OptionDescription]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [OptionDescription]
clevelandOptions

printFormattedException :: OptionSet -> SomeException -> IO Result
printFormattedException :: OptionSet -> SomeException -> IO Result
printFormattedException OptionSet
opts SomeException
se =
  case SomeException -> Maybe CallStackAnnotation
forall ann. ExceptionAnnotation ann => SomeException -> Maybe ann
lookupAnnEx SomeException
se of
    Maybe CallStackAnnotation
Nothing -> Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> Result
testFailed (String -> Result) -> String -> Result
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
se
    Just (CallStackAnnotation CallStack
cs) -> String -> Result
testFailed (String -> Result) -> (Builder -> String) -> Builder -> Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> String
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (Builder -> Result) -> IO Builder -> IO Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> CallStack -> String -> IO Builder
formatError Natural
contextLines CallStack
cs (
      SomeException -> String
forall e. Exception e => e -> String
displayException (SomeException -> String) -> SomeException -> String
forall a b. (a -> b) -> a -> b
$ forall ann.
ExceptionAnnotation ann =>
SomeException -> SomeException
removeAnnEx @CallStackAnnotation SomeException
se
      )
  where
    ContextLinesOpt Natural
contextLines = OptionSet -> ContextLinesOpt
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
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 :: MVar ()
lock = IO (MVar ()) -> MVar ()
forall a. IO a -> a
Unsafe.unsafePerformIO (() -> IO (MVar ())
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
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 :: TestTree -> IO ()
clevelandMain =
  [Ingredient] -> TestTree -> IO ()
clevelandMainWithIngredients [Ingredient]
defaultIngredients (TestTree -> IO ()) -> (TestTree -> TestTree) -> TestTree -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestTree -> TestTree
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 :: [Ingredient] -> TestTree -> IO ()
clevelandMainWithIngredients [Ingredient]
ingredients TestTree
tree = do
  Bool
ciSwitch <- IO Bool
withinCI
  [Ingredient] -> TestTree -> IO ()
defaultMainWithIngredients
    ([Ingredient]
clevelandIngredients [Ingredient] -> [Ingredient] -> [Ingredient]
forall a. Semigroup a => a -> a -> a
<> [Ingredient]
ingredients)
    (Bool -> TestTree -> TestTree
loadOptionSwitcher Bool
ciSwitch (TestTree -> TestTree)
-> (TestTree -> TestTree) -> TestTree -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestTree -> TestTree
setupTempDatadirIfNeeded (TestTree -> TestTree)
-> (TestTree -> TestTree) -> TestTree -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestTree -> TestTree
loadTastyEnv (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ TestTree
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 :: [Ingredient]
clevelandIngredients =
  [ [OptionDescription] -> Ingredient
includingOptions [OptionDescription]
clevelandOptions
  ]

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

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

-- | 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 :: IO Bool
withinCI = String -> IO (Maybe String)
lookupEnv String
"CI" IO (Maybe String) -> (Maybe String -> Bool) -> IO Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
  Just String
"1"                       -> Bool
True
  Just ((Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Char -> Char
C.toLower -> String
"true") -> Bool
True
  Maybe String
_                              -> Bool
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 :: ((forall a. (NetworkEnv -> IO a) -> IO a) -> TestTree) -> TestTree
whenNetworkEnabled (forall a. (NetworkEnv -> IO a) -> IO a) -> TestTree
mkTestTree =
  (OptionSet -> TestTree) -> TestTree
AskOptions \OptionSet
optionSet ->
    let TastyEnv forall a. (NetworkEnv -> IO a) -> IO a
useNetworkEnv = OptionSet -> TastyEnv
tastyEnvFromOpts OptionSet
optionSet
      in String -> [TestTree] -> TestTree
testGroup String
onNetworkTag [ (forall a. (NetworkEnv -> IO a) -> IO a) -> TestTree
mkTestTree forall a. (NetworkEnv -> IO a) -> IO a
useNetworkEnv ]

-- | Modifies the 'NetworkEnv' for all the tests in the given test tree.
modifyNetworkEnv :: (NetworkEnv -> NetworkEnv) -> TestTree -> TestTree
modifyNetworkEnv :: (NetworkEnv -> NetworkEnv) -> TestTree -> TestTree
modifyNetworkEnv NetworkEnv -> NetworkEnv
f TestTree
tree =
  (OptionSet -> TestTree) -> TestTree
AskOptions \OptionSet
optionSet ->
  let tastyEnv :: TastyEnv
tastyEnv = OptionSet -> TastyEnv
tastyEnvFromOpts OptionSet
optionSet
    in TastyEnvOpt -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (Maybe TastyEnv -> TastyEnvOpt
TastyEnvOpt (Maybe TastyEnv -> TastyEnvOpt) -> Maybe TastyEnv -> TastyEnvOpt
forall a b. (a -> b) -> a -> b
$ TastyEnv -> Maybe TastyEnv
forall a. a -> Maybe a
Just ((NetworkEnv -> NetworkEnv) -> TastyEnv -> TastyEnv
mapTastyEnv NetworkEnv -> NetworkEnv
f TastyEnv
tastyEnv)) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
         TestTree
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
defaultValue = Maybe TastyEnv -> TastyEnvOpt
TastyEnvOpt Maybe TastyEnv
forall a. Maybe a
Nothing
  optionName :: Tagged TastyEnvOpt String
optionName = Tagged TastyEnvOpt String
""
  optionHelp :: Tagged TastyEnvOpt String
optionHelp = Tagged TastyEnvOpt String
""
  parseValue :: String -> Maybe TastyEnvOpt
parseValue = \String
_ -> Maybe TastyEnvOpt
forall a. Maybe a
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 :: TestTree -> TestTree
loadTastyEnv TestTree
tree =
  (OptionSet -> TestTree) -> TestTree
AskOptions \OptionSet
optionSet ->
    let tastyEnv :: TastyEnv
tastyEnv = OptionSet -> TastyEnv
tastyEnvFromOpts OptionSet
optionSet
    in TastyEnvOpt -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (Maybe TastyEnv -> TastyEnvOpt
TastyEnvOpt (Maybe TastyEnv -> TastyEnvOpt) -> Maybe TastyEnv -> TastyEnvOpt
forall a b. (a -> b) -> a -> b
$ TastyEnv -> Maybe TastyEnv
forall a. a -> Maybe a
Just TastyEnv
tastyEnv)
         TestTree
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
  { TastyEnv -> forall a. (NetworkEnv -> IO a) -> IO a
useNetworkEnv :: forall a. (NetworkEnv -> IO a) -> IO a
  }

mkTastyEnv :: IO NetworkEnv -> TastyEnv
mkTastyEnv :: IO NetworkEnv -> TastyEnv
mkTastyEnv IO NetworkEnv
mkEnv =
  TastyEnv :: (forall a. (NetworkEnv -> IO a) -> IO a) -> TastyEnv
TastyEnv
    { useNetworkEnv :: forall a. (NetworkEnv -> IO a) -> IO a
useNetworkEnv = \NetworkEnv -> IO a
cont ->
        MVar () -> (() -> IO a) -> IO a
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock ((() -> IO a) -> IO a) -> (() -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ IO a -> () -> IO a
forall a b. a -> b -> a
const do
          NetworkEnv
env <- IO NetworkEnv
memoMkEnv
          NetworkEnv -> IO a
cont NetworkEnv
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 :: IO NetworkEnv
memoMkEnv = IO (IO NetworkEnv) -> IO NetworkEnv
forall a. IO a -> a
Unsafe.unsafePerformIO (IO (IO NetworkEnv) -> IO NetworkEnv)
-> IO (IO NetworkEnv) -> IO NetworkEnv
forall a b. (a -> b) -> a -> b
$ IO NetworkEnv -> IO (IO NetworkEnv)
forall a. IO a -> IO (IO a)
memoize IO NetworkEnv
mkEnv

setupTempDatadirIfNeeded :: TestTree -> TestTree
setupTempDatadirIfNeeded :: TestTree -> TestTree
setupTempDatadirIfNeeded TestTree
tree = (DataDirOpt -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
askOption \case
    DataDirOpt Just{} -> TestTree
tree
    DataDirOpt Maybe String
Nothing ->
      -- NB: 'withResource' memoizes the resource, so it's pretty safe to
      -- 'unsafePerformIO' it -- it won't be created twice at least, and
      -- will be freed after the test tree is done running.
      IO String
-> (String -> IO ()) -> (IO String -> TestTree) -> TestTree
forall a. IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
withResource IO String
initTempDir String -> IO ()
removeDirectoryRecursive \IO String
iodir ->
        (NetworkEnv -> NetworkEnv) -> TestTree -> TestTree
modifyNetworkEnv ((Maybe String -> Identity (Maybe String))
-> NetworkEnv -> Identity NetworkEnv
Lens' NetworkEnv (Maybe String)
neMbTezosClientDataDirL ((Maybe String -> Identity (Maybe String))
 -> NetworkEnv -> Identity NetworkEnv)
-> Maybe String -> NetworkEnv -> NetworkEnv
forall s t a b. ASetter s t a b -> b -> s -> t
.~ String -> Maybe String
forall a. a -> Maybe a
Just (IO String -> String
forall a. IO a -> a
Unsafe.unsafePerformIO IO String
iodir)) TestTree
tree
  where
    initTempDir :: IO String
initTempDir = do
      String
tmpdir <- IO String
getCanonicalTemporaryDirectory
      String -> String -> IO String
createTempDirectory String
tmpdir String
"cleveland"
    neMbTezosClientDataDirL :: Lens' NetworkEnv (Maybe FilePath)
    neMbTezosClientDataDirL :: Lens' NetworkEnv (Maybe String)
neMbTezosClientDataDirL =
      (MorleyClientEnv -> f MorleyClientEnv)
-> NetworkEnv -> f NetworkEnv
Lens' NetworkEnv MorleyClientEnv
neMorleyClientEnvL ((MorleyClientEnv -> f MorleyClientEnv)
 -> NetworkEnv -> f NetworkEnv)
-> ((Maybe String -> f (Maybe String))
    -> MorleyClientEnv -> f MorleyClientEnv)
-> (Maybe String -> f (Maybe String))
-> NetworkEnv
-> f NetworkEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TezosClientEnv -> f TezosClientEnv)
-> MorleyClientEnv -> f MorleyClientEnv
Lens' MorleyClientEnv TezosClientEnv
mceTezosClientL ((TezosClientEnv -> f TezosClientEnv)
 -> MorleyClientEnv -> f MorleyClientEnv)
-> ((Maybe String -> f (Maybe String))
    -> TezosClientEnv -> f TezosClientEnv)
-> (Maybe String -> f (Maybe String))
-> MorleyClientEnv
-> f MorleyClientEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe String -> f (Maybe String))
-> TezosClientEnv -> f TezosClientEnv
Lens' TezosClientEnv (Maybe String)
tceMbTezosClientDataDirL

mapTastyEnv :: (NetworkEnv -> NetworkEnv) -> (TastyEnv -> TastyEnv)
mapTastyEnv :: (NetworkEnv -> NetworkEnv) -> TastyEnv -> TastyEnv
mapTastyEnv NetworkEnv -> NetworkEnv
g (TastyEnv forall a. (NetworkEnv -> IO a) -> IO a
f) =
  (forall a. (NetworkEnv -> IO a) -> IO a) -> TastyEnv
TastyEnv ((forall a. (NetworkEnv -> IO a) -> IO a) -> TastyEnv)
-> (forall a. (NetworkEnv -> IO a) -> IO a) -> TastyEnv
forall a b. (a -> b) -> a -> b
$ \NetworkEnv -> IO a
cont ->
    (NetworkEnv -> IO a) -> IO a
forall a. (NetworkEnv -> IO a) -> IO a
f (\NetworkEnv
networkEnv -> NetworkEnv -> IO a
cont (NetworkEnv -> NetworkEnv
g NetworkEnv
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 :: forall a. IO a -> IO (IO a)
memoize IO a
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
  MVar (Maybe a)
cache <- Maybe a -> IO (MVar (Maybe a))
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Maybe a
forall a. Maybe a
Nothing

  let
    readCache :: IO a
    readCache :: IO a
readCache =
      MVar (Maybe a) -> IO (Maybe a)
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar (Maybe a)
cache IO (Maybe a) -> (Maybe a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just a
a -> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
        Maybe a
Nothing ->
          MVar (Maybe a) -> (Maybe a -> IO (Maybe a, a)) -> IO a
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Maybe a)
cache ((Maybe a -> IO (Maybe a, a)) -> IO a)
-> (Maybe a -> IO (Maybe a, a)) -> IO a
forall a b. (a -> b) -> a -> b
$ \case
            Just a
a -> (Maybe a, a) -> IO (Maybe a, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
a, a
a)
            Maybe a
Nothing -> do
              a
a <- IO a
action
              pure (a -> Maybe a
forall a. a -> Maybe a
Just a
a, a
a)

  IO a -> IO (IO a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure IO a
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 :: Bool -> TestTree -> TestTree
loadOptionSwitcher Bool
ciFlag TestTree
testTree =
  forall v. IsOption v => (v -> TestTree) -> TestTree
askOption @RunModeOpt ((RunModeOpt -> TestTree) -> TestTree)
-> (RunModeOpt -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \RunModeOpt
mode -> case (RunModeOpt
mode, Bool
ciFlag) of
    (RunModeOpt
RunAllMode, Bool
_) -> TestTree
testTree
    (RunModeOpt
OnlyNetworkMode, Bool
_) -> TestTree -> TestTree
loadOnlyNetworkPattern TestTree
testTree
    (RunModeOpt
DisableNetworkMode, Bool
_) -> TestTree -> TestTree
loadNoNetworkPattern TestTree
testTree
    (RunModeOpt
DefaultMode, Bool
False) -> TestTree -> TestTree
loadNoNetworkPattern TestTree
testTree
    (RunModeOpt
DefaultMode, Bool
True) -> TestTree
testTree
  where
     loadOnlyNetworkPattern :: TestTree -> TestTree
     loadOnlyNetworkPattern :: TestTree -> TestTree
loadOnlyNetworkPattern = (TestPattern -> TestPattern) -> TestTree -> TestTree
forall v. IsOption v => (v -> v) -> TestTree -> TestTree
adjustOption (Expr -> TestPattern -> TestPattern
adjustExprToTestPattern Expr
runOnlyNetworkExpr)

     loadNoNetworkPattern :: TestTree -> TestTree
     loadNoNetworkPattern :: TestTree -> TestTree
loadNoNetworkPattern = (TestPattern -> TestPattern) -> TestTree -> TestTree
forall v. IsOption v => (v -> v) -> TestTree -> TestTree
adjustOption (Expr -> TestPattern -> TestPattern
adjustExprToTestPattern Expr
dontRunNetworkExpr)

     adjustExprToTestPattern :: Expr -> TestPattern -> TestPattern
     adjustExprToTestPattern :: Expr -> TestPattern -> TestPattern
adjustExprToTestPattern Expr
expr (TestPattern Maybe Expr
maybePattern) = Maybe Expr -> TestPattern
TestPattern (Maybe Expr -> TestPattern) -> Maybe Expr -> TestPattern
forall a b. (a -> b) -> a -> b
$ Expr -> Maybe Expr
forall a. a -> Maybe a
Just
       case Maybe Expr
maybePattern of
         Maybe Expr
Nothing -> Expr
expr
         Just Expr
ptrn -> Expr -> Expr -> Expr
And Expr
ptrn Expr
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 :: Expr
runOnlyNetworkExpr =
  Expr -> Expr -> Expr
Or
    (Expr -> Expr -> Expr
Or
      (Expr -> Expr -> Expr
Tasty.EQ (Expr -> Expr
Field (Int -> Expr
IntLit Int
1)) (String -> Expr
StringLit String
"On network"))
      (Expr -> Expr -> Expr
Tasty.EQ (Expr -> Expr
Field Expr
NF) (String -> Expr
StringLit String
"On network"))
    )
    (Expr -> String -> Expr
Match (Expr -> Expr
Field (Int -> Expr
IntLit Int
0)) String
".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 :: Expr
dontRunNetworkExpr =
  Expr -> Expr -> Expr
And
    (Expr -> Expr -> Expr
And
      (Expr -> Expr -> Expr
Tasty.NE (Expr -> Expr
Field (Int -> Expr
IntLit Int
1)) (String -> Expr
StringLit String
"On network"))
      (Expr -> Expr -> Expr
Tasty.NE (Expr -> Expr
Field Expr
NF) (String -> Expr
StringLit String
"On network"))
    )
    (Expr -> String -> Expr
NoMatch (Expr -> Expr
Field (Int -> Expr
IntLit Int
0)) String
".On network.")