Util.hs

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

-- Utility functions used in the @cleveland:test:cleveland-test@ test suite.
module TestSuite.Util
  ( runPropertyViaTasty
  , runViaTastyOnEmulator
  , runViaTastyOnNetwork
  , outcomeIsFailure
  , shouldFailWithMessage

  -- * Contracts
  , idContract
  , saveInStorageContract
  , saveSender

  -- * Misc
  , BigMapInStorage(..)
  ) where

import Lorentz

import Data.List (isInfixOf)
import Fmt (Buildable, build, indentF, pretty, unlinesF)
import Hedgehog (Property)
import System.Environment (lookupEnv, setEnv, unsetEnv)
import Test.Tasty.Hedgehog (testProperty)
import Test.Tasty.HUnit (Assertion, assertFailure, testCase)
import Test.Tasty.Options (OptionSet, singleOption)
import Test.Tasty.Providers (IsTest(run), TestName)
import Test.Tasty.Runners
  (FailureReason(TestFailed), Outcome(Failure, Success), Result(resultOutcome),
  TestTree(AskOptions, SingleTest))

import Test.Cleveland (ClevelandT, EmulatedT, MonadCleveland, attempt, failure)
import Test.Cleveland.Internal.Client (ClientM)
import Test.Cleveland.Internal.Pure (PureM)
import Test.Cleveland.Internal.Scenario
import Test.Cleveland.Tasty.Internal
  (RunOnEmulator(RunOnEmulator), RunOnNetwork(RunOnNetwork), whenNetworkEnabled)
import Test.Cleveland.Tasty.Internal.Options (ContextLinesOpt(ContextLinesOpt))

-- | Runs a cleveland action via Tasty, and performs some checks on the Tasty result.
--
-- It uses the Tasty options taken from the environment (CLI and environment variables).
-- It also sets 'ContextLinesOpt' to 0, otherwise the test report may capture
-- source code lines not actually related to the test.
--
-- These options can be overriden by passing in an additional 'OptionSet'.
runViaTastyOnEmulator :: TestName -> OptionSet -> EmulatedT PureM () -> (Result -> Assertion) -> TestTree
runViaTastyOnEmulator testName options clevelandTest checkResult =
  AskOptions $ \envOptions ->
    testCase testName $ do
      let allOptions = envOptions <> singleOption (ContextLinesOpt 0) <> options
      let tastyTest = RunOnEmulator (scenarioEmulated clevelandTest)
      tastyResult <- run allOptions tastyTest (\_ -> pure ())
      checkResult tastyResult

-- | Runs a cleveland action via Tasty, and performs some checks on the Tasty result.
--
-- It uses the Tasty options taken from the environment (CLI and environment variables).
-- It also sets 'ContextLinesOpt' to 0, otherwise the test report may capture
-- source code lines not actually related to the test.
--
-- These options can be overriden by passing in an additional 'OptionSet'.
runViaTastyOnNetwork :: TestName -> OptionSet -> ClevelandT ClientM () -> (Result -> Assertion) -> TestTree
runViaTastyOnNetwork testName options clevelandTest checkResult =
  whenNetworkEnabled $ \_ ->
    AskOptions $ \envOptions ->
      testCase testName $ do
        let allOptions = envOptions <> singleOption (ContextLinesOpt 0) <> options
        let tastyTest = RunOnNetwork (scenario clevelandTest)
        tastyResult <- run allOptions tastyTest (\_ -> pure ())
        checkResult tastyResult

-- | Runs a cleveland property test via Tasy, and performs some checks on the Tasty result.
--
-- It uses the Tasty options taken from the environment (CLI and environment variables).
-- It also sets 'ContextLinesOpt' to 0, otherwise the test report may capture
-- source code lines not actually related to the test.
--
-- These options can be overriden by passing in an additional 'OptionSet'.
runPropertyViaTasty :: TestName -> OptionSet -> Property -> (Result -> Assertion) -> TestTree
runPropertyViaTasty testName options prop checkResult =
  AskOptions $ \envOptions ->
    testCase testName $ do
      let
        allOptions = envOptions <> singleOption (ContextLinesOpt 0) <> options
        testTree = testProperty "" prop
      tastyResult <- case testTree of
        SingleTest _ test ->
          bracket saveEnv restoreEnv $ \_ -> (run allOptions test (\_ -> pure ()))
        _ -> error "impossible"
      checkResult tastyResult
  where
    saveEnv    = lookupEnv "TERM" <* setEnv "TERM" "dumb"
    restoreEnv = maybe (unsetEnv "TERM") (setEnv "TERM")

-- | Checks that a Tasty test failed because the nested cleveland test failed
-- (and not because, for example, the test framework threw an exception).
outcomeIsFailure :: HasCallStack => Result -> Assertion
outcomeIsFailure tastyResult =
  case resultOutcome tastyResult of
    Failure TestFailed -> pass
    Failure reason ->
      assertFailure $ toString $ unlines
        [ "Expected Tasty test to fail because the cleveland test failed, but failed because:"
        , pretty reason
        ]
    Success ->
      assertFailure "Expected Tasty test to fail, but it succeeded"

-- | Check that a Cleveland test fails and that the error message contains
-- the given string.
shouldFailWithMessage
  :: forall any caps m.
     (HasCallStack, MonadCleveland caps m, Buildable any)
  => String -> m any -> m ()
shouldFailWithMessage expectedMessage action  = do
  attempt @SomeException action >>= \case
    Right x ->
      failure $ "Expected action to fail, but it succeeded with: " <> pretty x
    Left ex ->
      unless (expectedMessage `isInfixOf` displayException ex) $
        failure $ unlinesF
          [ "━━━━━ Expected error message to contain:"
          , indentF 2 $ build expectedMessage
          , ""
          , "━━━━━ Actual error message was:"
          , indentF 2 $ build $ displayException ex
          ]

----------------------------------------------------------------------------
-- Test contracts
----------------------------------------------------------------------------

-- | Simple contract that does nothing when called.
idContract :: (NiceParameterFull cp, NiceStorageFull st) => Contract cp st ()
idContract = defaultContract $
  cdr #
  nil @Operation #
  pair

-- | Simple contract that takes a parameter and saves it in its storage.
saveInStorageContract :: (NiceParameterFull st, NiceStorageFull st) => Contract st st ()
saveInStorageContract = defaultContract $
  car #
  nil @Operation #
  pair

-- | Simple contract that stores the sender's address in its storage.
saveSender :: Contract () [Address] ()
saveSender = defaultContract $
  cdr # sender # cons # nil @Operation # pair


----------------------------------------------------------------------------
-- Misc
----------------------------------------------------------------------------

-- | Storage for the @big_map_in_storage.tz@ contract.
-- It is placed in this module to work around the GHC stage restriction.
data BigMapInStorage = BigMapInStorage
  { ssField1 :: BigMap Integer Integer
  , ssField2 :: Natural
  }
  deriving stock (Generic, Show, Eq)
  deriving anyclass (IsoValue, Buildable)