{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Cardano.CLI.Util
  ( assertDirectoryMissing
  , checkTxCddlFormat
  , checkTextEnvelopeFormat
  , equivalence
  , execCardanoCLI
  , execCardanoCLIWithEnvVars
  , execDetailCardanoCLI
  , execDetailConfigCardanoCLI
  , tryExecCardanoCLI
  , propertyOnce
  , withSnd
  , noteInputFile
  , noteTempFile
  , redactJsonField
  , watchdogProp
  )
where

import Cardano.Api

import Cardano.CLI.Read

import Control.Monad
import Control.Monad.Catch hiding (bracket_)
import Control.Monad.Morph (hoist)
import Control.Monad.Trans.Resource (ResourceT, runResourceT)
import Data.Aeson qualified as Aeson
import Data.Aeson.Encode.Pretty qualified as Aeson
import Data.Aeson.Key qualified as Aeson
import Data.Aeson.KeyMap qualified as Aeson
import Data.ByteString.Lazy qualified as LBS
import Data.Function ((&))
import Data.List qualified as List
import Data.Monoid (Last (..))
import GHC.IO.Exception (ExitCode (..))
import GHC.Stack (CallStack, HasCallStack)
import GHC.Stack qualified as GHC
import System.Directory qualified as IO
import System.Environment qualified as IO
import System.Exit qualified as IO
import System.FilePath (takeDirectory)
import System.IO.Unsafe qualified as IO
import System.Process (CreateProcess)
import System.Process qualified as IO

import Hedgehog qualified as H
import Hedgehog.Extras (ExecConfig)
import Hedgehog.Extras qualified as H
import Hedgehog.Extras.Test (ExecConfig (..))
import Hedgehog.Internal.Property (Diff, MonadTest, Property (..), liftTest, mkTest)
import Hedgehog.Internal.Property qualified as H
import Hedgehog.Internal.Show (ValueDiff (ValueSame), mkValue, showPretty, valueDiff)
import Hedgehog.Internal.Source (getCaller)

-- | Execute cardano-cli via the command line.
--
-- Waits for the process to finish and returns the stdout.
execCardanoCLI
  :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)
  => [String]
  -- ^ Arguments to the CLI command
  -> m String
  -- ^ Captured stdout
execCardanoCLI :: forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
[String] -> m String
execCardanoCLI = (HasCallStack => [String] -> m String) -> [String] -> m String
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => [String] -> m String) -> [String] -> m String)
-> (HasCallStack => [String] -> m String) -> [String] -> m String
forall a b. (a -> b) -> a -> b
$ String -> String -> [String] -> m String
forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
String -> String -> [String] -> m String
H.execFlex String
"cardano-cli" String
"CARDANO_CLI"

-- | Execute cardano-cli via the command line but set
-- environment variables. Fails if the process returns a non-zero exit code.
--
-- Waits for the process to finish and returns the stdout.
execCardanoCLIWithEnvVars
  :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)
  => [(String, String)]
  -- ^ Environment variables to set
  -> [String]
  -- ^ Arguments to the CLI command
  -> m String
execCardanoCLIWithEnvVars :: forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
[(String, String)] -> [String] -> m String
execCardanoCLIWithEnvVars [(String, String)]
envVars [String]
args = (HasCallStack => m String) -> m String
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m String) -> m String)
-> (HasCallStack => m String) -> m String
forall a b. (a -> b) -> a -> b
$ do
  env <- IO [(String, String)] -> m [(String, String)]
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO IO [(String, String)]
IO.getEnvironment
  result <-
    execDetailConfigCardanoCLI
      H.defaultExecConfig
        { H.execConfigEnv = Last $ Just (envVars ++ env)
        }
      args
  case result of
    (ExitFailure Int
_, String
_, String
stderr) -> do
      String -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.note_ String
stderr
      m String
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
H.failure
    (ExitCode
ExitSuccess, String
stdout, String
_) -> String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return String
stdout

-- | Execute cardano-cli via the command line, expecting it to fail.
--
-- Waits for the process to finish and returns the exit code, stdout and stderr.
execDetailCardanoCLI
  :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)
  => [String]
  -- ^ Arguments to the CLI command
  -> m (IO.ExitCode, String, String)
  -- ^ exit code, stdout, stderr
execDetailCardanoCLI :: forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
[String] -> m (ExitCode, String, String)
execDetailCardanoCLI [String]
params = (HasCallStack => m (ExitCode, String, String))
-> m (ExitCode, String, String)
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m (ExitCode, String, String))
 -> m (ExitCode, String, String))
-> (HasCallStack => m (ExitCode, String, String))
-> m (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ ExecConfig -> [String] -> m (ExitCode, String, String)
forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
ExecConfig -> [String] -> m (ExitCode, String, String)
execDetailConfigCardanoCLI ExecConfig
H.defaultExecConfig [String]
params

-- | Execute cardano-cli via the command line, expecting it to fail, and accepting custom config.
--
-- Waits for the process to finish and returns the exit code, stdout and stderr.
execDetailConfigCardanoCLI
  :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)
  => ExecConfig
  -- ^ Configuration for the execution
  -> [String]
  -- ^ Arguments to the CLI command
  -> m (IO.ExitCode, String, String)
  -- ^ Exit code, stdout, stderr
execDetailConfigCardanoCLI :: forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
ExecConfig -> [String] -> m (ExitCode, String, String)
execDetailConfigCardanoCLI ExecConfig
cfg = (HasCallStack => [String] -> m (ExitCode, String, String))
-> [String] -> m (ExitCode, String, String)
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => [String] -> m (ExitCode, String, String))
 -> [String] -> m (ExitCode, String, String))
-> (HasCallStack => [String] -> m (ExitCode, String, String))
-> [String]
-> m (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ ExecConfig
-> String -> String -> [String] -> m (ExitCode, String, String)
forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
ExecConfig
-> String -> String -> [String] -> m (ExitCode, String, String)
execDetailFlex ExecConfig
cfg String
"cardano-cli" String
"CARDANO_CLI"

procFlex'
  :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)
  => ExecConfig
  -> String
  -- ^ Cabal package name corresponding to the executable
  -> String
  -- ^ Environment variable pointing to the binary to run
  -> [String]
  -- ^ Arguments to the CLI command
  -> m CreateProcess
  -- ^ Captured stdout
procFlex' :: forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
ExecConfig -> String -> String -> [String] -> m CreateProcess
procFlex' ExecConfig
execConfig String
pkg String
binaryEnv [String]
arguments = m CreateProcess -> m CreateProcess
(HasCallStack => m CreateProcess) -> m CreateProcess
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack (m CreateProcess -> m CreateProcess)
-> (m CreateProcess -> m CreateProcess)
-> m CreateProcess
-> m CreateProcess
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m CreateProcess -> m CreateProcess
forall (m :: * -> *) a.
(MonadTest m, MonadCatch m, HasCallStack) =>
m a -> m a
H.evalM (m CreateProcess -> m CreateProcess)
-> m CreateProcess -> m CreateProcess
forall a b. (a -> b) -> a -> b
$ do
  bin <- String -> String -> m String
forall (m :: * -> *).
(HasCallStack, MonadTest m, MonadIO m) =>
String -> String -> m String
H.binFlex String
pkg String
binaryEnv
  return
    (IO.proc bin arguments)
      { IO.env = getLast $ execConfigEnv execConfig
      , IO.cwd = getLast $ execConfigCwd execConfig
      }

execDetailFlex
  :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)
  => ExecConfig
  -> String
  -> String
  -> [String]
  -> m (IO.ExitCode, String, String)
-- ^ exit code, stdout, stderr
execDetailFlex :: forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
ExecConfig
-> String -> String -> [String] -> m (ExitCode, String, String)
execDetailFlex ExecConfig
execConfig String
pkgBin String
envBin [String]
arguments = (HasCallStack => m (ExitCode, String, String))
-> m (ExitCode, String, String)
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m (ExitCode, String, String))
 -> m (ExitCode, String, String))
-> (HasCallStack => m (ExitCode, String, String))
-> m (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ do
  cp <- ExecConfig -> String -> String -> [String] -> m CreateProcess
forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
ExecConfig -> String -> String -> [String] -> m CreateProcess
procFlex' ExecConfig
execConfig String
pkgBin String
envBin [String]
arguments
  H.annotate . ("Command: " <>) $ case IO.cmdspec cp of
    IO.ShellCommand String
cmd -> String
cmd
    IO.RawCommand String
cmd [String]
args -> String
cmd String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
List.unwords [String]
args
  H.evalIO $ IO.readCreateProcessWithExitCode cp ""

tryExecCardanoCLI
  :: (MonadCatch m, MonadIO m, HasCallStack)
  => [String]
  -- ^ Arguments to the CLI command
  -> H.PropertyT m (Either H.Failure String)
  -- ^ Captured stdout, or error in case of failures
tryExecCardanoCLI :: forall (m :: * -> *).
(MonadCatch m, MonadIO m, HasCallStack) =>
[String] -> PropertyT m (Either Failure String)
tryExecCardanoCLI [String]
args =
  (HasCallStack => [String] -> PropertyT m String)
-> [String] -> PropertyT m String
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack (String -> String -> [String] -> PropertyT m String
forall (m :: * -> *).
(MonadTest m, MonadCatch m, MonadIO m, HasCallStack) =>
String -> String -> [String] -> m String
H.execFlex String
"cardano-cli" String
"CARDANO_CLI") [String]
args
    PropertyT m String
-> (PropertyT m String -> TestT (GenT m) String)
-> TestT (GenT m) String
forall a b. a -> (a -> b) -> b
& PropertyT m String -> TestT (GenT m) String
forall (m :: * -> *) a. PropertyT m a -> TestT (GenT m) a
H.unPropertyT
    TestT (GenT m) String
-> (TestT (GenT m) String
    -> ExceptT Failure (WriterT Journal (GenT m)) String)
-> ExceptT Failure (WriterT Journal (GenT m)) String
forall a b. a -> (a -> b) -> b
& TestT (GenT m) String
-> ExceptT Failure (WriterT Journal (GenT m)) String
forall (m :: * -> *) a.
TestT m a -> ExceptT Failure (WriterT Journal m) a
H.unTest
    ExceptT Failure (WriterT Journal (GenT m)) String
-> (ExceptT Failure (WriterT Journal (GenT m)) String
    -> WriterT Journal (GenT m) (Either Failure String))
-> WriterT Journal (GenT m) (Either Failure String)
forall a b. a -> (a -> b) -> b
& ExceptT Failure (WriterT Journal (GenT m)) String
-> WriterT Journal (GenT m) (Either Failure String)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
    WriterT Journal (GenT m) (Either Failure String)
-> (WriterT Journal (GenT m) (Either Failure String)
    -> ExceptT
         Failure (WriterT Journal (GenT m)) (Either Failure String))
-> ExceptT
     Failure (WriterT Journal (GenT m)) (Either Failure String)
forall a b. a -> (a -> b) -> b
& WriterT Journal (GenT m) (Either Failure String)
-> ExceptT
     Failure (WriterT Journal (GenT m)) (Either Failure String)
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
    ExceptT Failure (WriterT Journal (GenT m)) (Either Failure String)
-> (ExceptT
      Failure (WriterT Journal (GenT m)) (Either Failure String)
    -> TestT (GenT m) (Either Failure String))
-> TestT (GenT m) (Either Failure String)
forall a b. a -> (a -> b) -> b
& ExceptT Failure (WriterT Journal (GenT m)) (Either Failure String)
-> TestT (GenT m) (Either Failure String)
forall (m :: * -> *) a.
ExceptT Failure (WriterT Journal m) a -> TestT m a
H.TestT
    TestT (GenT m) (Either Failure String)
-> (TestT (GenT m) (Either Failure String)
    -> PropertyT m (Either Failure String))
-> PropertyT m (Either Failure String)
forall a b. a -> (a -> b) -> b
& TestT (GenT m) (Either Failure String)
-> PropertyT m (Either Failure String)
forall (m :: * -> *) a. TestT (GenT m) a -> PropertyT m a
H.PropertyT

-- | Checks that the 'tvType' and 'tvDescription' are equivalent between two files.
checkTextEnvelopeFormat
  :: (MonadTest m, MonadIO m, HasCallStack)
  => TextEnvelopeType
  -> FilePath
  -- ^ On-disk reference/golden file
  -> FilePath
  -- ^ Newly created file
  -> m ()
checkTextEnvelopeFormat :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
TextEnvelopeType -> String -> String -> m ()
checkTextEnvelopeFormat TextEnvelopeType
tve String
reference String
created = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  eRefTextEnvelope <- IO (Either (FileError TextEnvelopeError) TextEnvelope)
-> m (Either (FileError TextEnvelopeError) TextEnvelope)
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO (Either (FileError TextEnvelopeError) TextEnvelope)
 -> m (Either (FileError TextEnvelopeError) TextEnvelope))
-> IO (Either (FileError TextEnvelopeError) TextEnvelope)
-> m (Either (FileError TextEnvelopeError) TextEnvelope)
forall a b. (a -> b) -> a -> b
$ TextEnvelopeType
-> String -> IO (Either (FileError TextEnvelopeError) TextEnvelope)
readTextEnvelopeOfTypeFromFile TextEnvelopeType
tve String
reference
  refTextEnvelope <- handleTextEnvelope eRefTextEnvelope

  eCreatedTextEnvelope <- H.evalIO $ readTextEnvelopeOfTypeFromFile tve created
  createdTextEnvelope <- handleTextEnvelope eCreatedTextEnvelope

  typeTitleEquivalence refTextEnvelope createdTextEnvelope
 where
  handleTextEnvelope
    :: MonadTest m
    => Either (FileError TextEnvelopeError) TextEnvelope
    -> m TextEnvelope
  handleTextEnvelope :: forall (m :: * -> *).
MonadTest m =>
Either (FileError TextEnvelopeError) TextEnvelope -> m TextEnvelope
handleTextEnvelope = \case
    Right TextEnvelope
refTextEnvelope ->
      TextEnvelope -> m TextEnvelope
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return TextEnvelope
refTextEnvelope
    Left FileError TextEnvelopeError
fileErr ->
      CallStack -> Maybe Diff -> String -> m TextEnvelope
forall (m :: * -> *) a.
MonadTest m =>
CallStack -> Maybe Diff -> String -> m a
failWithCustom CallStack
HasCallStack => CallStack
GHC.callStack Maybe Diff
forall a. Maybe a
Nothing (String -> m TextEnvelope)
-> (FileError TextEnvelopeError -> String)
-> FileError TextEnvelopeError
-> m TextEnvelope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc AnsiStyle -> String
docToString (Doc AnsiStyle -> String)
-> (FileError TextEnvelopeError -> Doc AnsiStyle)
-> FileError TextEnvelopeError
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileError TextEnvelopeError -> Doc AnsiStyle
forall e ann. Error e => e -> Doc ann
forall ann. FileError TextEnvelopeError -> Doc ann
prettyError) (FileError TextEnvelopeError -> m TextEnvelope)
-> FileError TextEnvelopeError -> m TextEnvelope
forall a b. (a -> b) -> a -> b
$ FileError TextEnvelopeError
fileErr
  -- NB: The created type is what is defined in the particulr `HasTextEnvelope` instance.
  typeTitleEquivalence :: (MonadTest m, HasCallStack) => TextEnvelope -> TextEnvelope -> m ()
  typeTitleEquivalence :: forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
TextEnvelope -> TextEnvelope -> m ()
typeTitleEquivalence
    (TextEnvelope TextEnvelopeType
onDiskRefType TextEnvelopeDescr
refTitle ByteString
_)
    (TextEnvelope TextEnvelopeType
createdType TextEnvelopeDescr
createdTitle ByteString
_) = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
      case TextEnvelopeType -> TextEnvelopeType -> Either TextEnvelopeError ()
expectTextEnvelopeOfType TextEnvelopeType
createdType TextEnvelopeType
onDiskRefType of
        Right () -> TextEnvelopeDescr -> TextEnvelopeDescr -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
equivalence TextEnvelopeDescr
refTitle TextEnvelopeDescr
createdTitle
        Left TextEnvelopeError
typeErr ->
          CallStack -> Maybe Diff -> String -> m ()
forall (m :: * -> *) a.
MonadTest m =>
CallStack -> Maybe Diff -> String -> m a
failWithCustom CallStack
HasCallStack => CallStack
GHC.callStack Maybe Diff
forall a. Maybe a
Nothing (String -> m ())
-> (TextEnvelopeError -> String) -> TextEnvelopeError -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc AnsiStyle -> String
docToString (Doc AnsiStyle -> String)
-> (TextEnvelopeError -> Doc AnsiStyle)
-> TextEnvelopeError
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextEnvelopeError -> Doc AnsiStyle
forall e ann. Error e => e -> Doc ann
forall ann. TextEnvelopeError -> Doc ann
prettyError) (TextEnvelopeError -> m ()) -> TextEnvelopeError -> m ()
forall a b. (a -> b) -> a -> b
$ TextEnvelopeError
typeErr

-- TODO: Expose from cardano-api
expectTextEnvelopeOfType :: TextEnvelopeType -> TextEnvelopeType -> Either TextEnvelopeError ()
expectTextEnvelopeOfType :: TextEnvelopeType -> TextEnvelopeType -> Either TextEnvelopeError ()
expectTextEnvelopeOfType TextEnvelopeType
createdType TextEnvelopeType
onDiskRefType =
  Bool -> Either TextEnvelopeError () -> Either TextEnvelopeError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TextEnvelopeType
createdType TextEnvelopeType -> TextEnvelopeType -> Bool
forall a. Eq a => a -> a -> Bool
== TextEnvelopeType
onDiskRefType) (Either TextEnvelopeError () -> Either TextEnvelopeError ())
-> Either TextEnvelopeError () -> Either TextEnvelopeError ()
forall a b. (a -> b) -> a -> b
$
    Bool -> Either TextEnvelopeError () -> Either TextEnvelopeError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TextEnvelopeType
createdType TextEnvelopeType -> TextEnvelopeType -> Bool
`legacyComparison` TextEnvelopeType
onDiskRefType) (Either TextEnvelopeError () -> Either TextEnvelopeError ())
-> Either TextEnvelopeError () -> Either TextEnvelopeError ()
forall a b. (a -> b) -> a -> b
$
      TextEnvelopeError -> Either TextEnvelopeError ()
forall a b. a -> Either a b
Left ([TextEnvelopeType] -> TextEnvelopeType -> TextEnvelopeError
TextEnvelopeTypeError [TextEnvelopeType
createdType] TextEnvelopeType
onDiskRefType)

checkTxCddlFormat
  :: (MonadTest m, MonadIO m, HasCallStack)
  => FilePath
  -- ^ Reference/golden file
  -> FilePath
  -- ^ Newly created file
  -> m ()
checkTxCddlFormat :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
String -> String -> m ()
checkTxCddlFormat String
referencePath String
createdPath = do
  fileExists <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
IO.doesFileExist String
referencePath

  if fileExists
    then do
      reference <- H.evalIO $ fileOrPipe referencePath
      created <- H.evalIO $ fileOrPipe createdPath
      r <- H.evalIO $ readTx reference
      c <- H.evalIO $ readTx created
      r H.=== c
    else
      if createFiles
        then do
          -- CREATE_GOLDEN_FILES is set, so we create any golden files that don't
          -- already exist.
          H.note_ $ "Creating golden file " <> referencePath
          H.createDirectoryIfMissing_ (takeDirectory referencePath)
          H.readFile createdPath >>= H.writeFile referencePath
        else do
          H.note_ $
            mconcat
              [ "Golden file " <> referencePath
              , " does not exist.  To create, run with CREATE_GOLDEN_FILES=1"
              ]
          H.failure

-- | Whether the test should create the golden files if the file does ont exist.
createFiles :: Bool
createFiles :: Bool
createFiles = IO Bool -> Bool
forall a. IO a -> a
IO.unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
  value <- String -> IO (Maybe String)
IO.lookupEnv String
"CREATE_GOLDEN_FILES"
  return $ value == Just "1"

-- | Asserts that the given directory is missing.
assertDirectoryMissing :: (MonadTest m, MonadIO m, HasCallStack) => FilePath -> m ()
assertDirectoryMissing :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
String -> m ()
assertDirectoryMissing String
dir = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  exists <- IO Bool -> m Bool
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
IO.doesDirectoryExist String
dir
  when exists $ H.failWithCustom GHC.callStack Nothing (dir <> " should not have been created.")

--------------------------------------------------------------------------------
-- Helpers, Error rendering & Clean up
--------------------------------------------------------------------------------

cardanoCliPath :: FilePath
cardanoCliPath :: String
cardanoCliPath = String
"cardano-cli"

-- | Return the input file path after annotating it relative to the project root directory
noteInputFile :: (MonadTest m, HasCallStack) => FilePath -> m FilePath
noteInputFile :: forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
String -> m String
noteInputFile String
filePath = (HasCallStack => m String) -> m String
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m String) -> m String)
-> (HasCallStack => m String) -> m String
forall a b. (a -> b) -> a -> b
$ do
  String -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.annotate (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
cardanoCliPath String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
filePath
  String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return String
filePath

-- | Return the test file path after annotating it relative to the project root directory
noteTempFile :: (MonadTest m, HasCallStack) => FilePath -> FilePath -> m FilePath
noteTempFile :: forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
String -> String -> m String
noteTempFile String
tempDir String
filePath = (HasCallStack => m String) -> m String
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m String) -> m String)
-> (HasCallStack => m String) -> m String
forall a b. (a -> b) -> a -> b
$ do
  let relPath :: String
relPath = String
tempDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
filePath
  String -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.annotate (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
cardanoCliPath String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
relPath
  String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return String
relPath

-- | Return the supply value with the result of the supplied function as a tuple
withSnd :: (a -> b) -> a -> (a, b)
withSnd :: forall a b. (a -> b) -> a -> (a, b)
withSnd a -> b
f a
a = (a
a, a -> b
f a
a)

-- These were lifted from hedgehog and slightly modified

propertyOnce :: H.PropertyT (ResourceT IO) () -> H.Property
propertyOnce :: PropertyT (ResourceT IO) () -> Property
propertyOnce = TestLimit -> Property -> Property
H.withTests TestLimit
1 (Property -> Property)
-> (PropertyT (ResourceT IO) () -> Property)
-> PropertyT (ResourceT IO) ()
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShrinkLimit -> Property -> Property
H.withShrinks ShrinkLimit
0 (Property -> Property)
-> (PropertyT (ResourceT IO) () -> Property)
-> PropertyT (ResourceT IO) ()
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
H.property (PropertyT IO () -> Property)
-> (PropertyT (ResourceT IO) () -> PropertyT IO ())
-> PropertyT (ResourceT IO) ()
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. ResourceT IO a -> IO a)
-> PropertyT (ResourceT IO) () -> PropertyT IO ()
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> PropertyT m b -> PropertyT n b
hoist ResourceT IO a -> IO a
forall a. ResourceT IO a -> IO a
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT

-- | Check for equivalence between two types and perform a file cleanup on failure.
equivalence
  :: (MonadTest m, Eq a, Show a, HasCallStack)
  => a
  -> a
  -> m ()
equivalence :: forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
equivalence a
x a
y = do
  ok <- Bool -> m Bool
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => a -> m a
H.eval (a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y)
  if ok
    then H.success
    else failDiffCustom GHC.callStack x y

-- | Takes a 'CallStack' so the error can be rendered at the appropriate call site.
failWithCustom :: MonadTest m => CallStack -> Maybe Diff -> String -> m a
failWithCustom :: forall (m :: * -> *) a.
MonadTest m =>
CallStack -> Maybe Diff -> String -> m a
failWithCustom CallStack
cs Maybe Diff
mdiff String
msg =
  Test a -> m a
forall a. Test a -> m a
forall (m :: * -> *) a. MonadTest m => Test a -> m a
liftTest (Test a -> m a) -> Test a -> m a
forall a b. (a -> b) -> a -> b
$ (Either Failure a, Journal) -> Test a
forall a. (Either Failure a, Journal) -> Test a
mkTest (Failure -> Either Failure a
forall a b. a -> Either a b
Left (Failure -> Either Failure a) -> Failure -> Either Failure a
forall a b. (a -> b) -> a -> b
$ Maybe Span -> String -> Maybe Diff -> Failure
H.Failure (CallStack -> Maybe Span
getCaller CallStack
cs) String
msg Maybe Diff
mdiff, Journal
forall a. Monoid a => a
mempty)

-- | Fails with an error that shows the difference between two values.
failDiffCustom :: (MonadTest m, Show a) => CallStack -> a -> a -> m ()
failDiffCustom :: forall (m :: * -> *) a.
(MonadTest m, Show a) =>
CallStack -> a -> a -> m ()
failDiffCustom CallStack
cS a
x a
y =
  case Value -> Value -> ValueDiff
valueDiff (Value -> Value -> ValueDiff)
-> Maybe Value -> Maybe (Value -> ValueDiff)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Maybe Value
forall a. Show a => a -> Maybe Value
mkValue a
x Maybe (Value -> ValueDiff) -> Maybe Value -> Maybe ValueDiff
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> Maybe Value
forall a. Show a => a -> Maybe Value
mkValue a
y of
    Maybe ValueDiff
Nothing ->
      (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
        CallStack -> Maybe Diff -> String -> m ()
forall (m :: * -> *) a.
MonadTest m =>
CallStack -> Maybe Diff -> String -> m a
failWithCustom CallStack
cS Maybe Diff
forall a. Maybe a
Nothing (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
          [String] -> String
Prelude.unlines
            [ String
"Failed"
            , String
"━━ lhs ━━"
            , a -> String
forall a. Show a => a -> String
showPretty a
x
            , String
"━━ rhs ━━"
            , a -> String
forall a. Show a => a -> String
showPretty a
y
            ]
    Just vdiff :: ValueDiff
vdiff@(ValueSame Value
_) ->
      (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
        CallStack -> Maybe Diff -> String -> m ()
forall (m :: * -> *) a.
MonadTest m =>
CallStack -> Maybe Diff -> String -> m a
failWithCustom
          CallStack
cS
          ( Diff -> Maybe Diff
forall a. a -> Maybe a
Just (Diff -> Maybe Diff) -> Diff -> Maybe Diff
forall a b. (a -> b) -> a -> b
$
              String -> String -> String -> String -> String -> ValueDiff -> Diff
H.Diff String
"━━━ Failed (" String
"" String
"no differences" String
"" String
") ━━━" ValueDiff
vdiff
          )
          String
""
    Just ValueDiff
vdiff ->
      (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
        CallStack -> Maybe Diff -> String -> m ()
forall (m :: * -> *) a.
MonadTest m =>
CallStack -> Maybe Diff -> String -> m a
failWithCustom
          CallStack
cS
          ( Diff -> Maybe Diff
forall a. a -> Maybe a
Just (Diff -> Maybe Diff) -> Diff -> Maybe Diff
forall a b. (a -> b) -> a -> b
$
              String -> String -> String -> String -> String -> ValueDiff -> Diff
H.Diff String
"━━━ Failed (" String
"- lhs" String
") (" String
"+ rhs" String
") ━━━" ValueDiff
vdiff
          )
          String
""

redactJsonField
  :: ()
  => MonadTest m
  => MonadIO m
  => HasCallStack
  => Text
  -> Text
  -> FilePath
  -> FilePath
  -> m ()
redactJsonField :: forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
Text -> Text -> String -> String -> m ()
redactJsonField Text
fieldName Text
replacement String
sourceFilePath String
targetFilePath = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  contents <- IO ByteString -> m ByteString
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
LBS.readFile String
sourceFilePath
  case Aeson.eitherDecode contents :: Either String Aeson.Value of
    Left String
err -> CallStack -> Maybe Diff -> String -> m ()
forall (m :: * -> *) a.
MonadTest m =>
CallStack -> Maybe Diff -> String -> m a
failWithCustom CallStack
HasCallStack => CallStack
GHC.callStack Maybe Diff
forall a. Maybe a
Nothing String
err
    Right Value
json -> do
      redactedJson <- case Value
json of
        Aeson.Object Object
obj ->
          Value -> m Value
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Object -> Value
Aeson.Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ ((Key -> Value -> Value) -> Object -> Object)
-> Object -> (Key -> Value -> Value) -> Object
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Key -> Value -> Value) -> Object -> Object
forall a b. (Key -> a -> b) -> KeyMap a -> KeyMap b
Aeson.mapWithKey Object
obj ((Key -> Value -> Value) -> Object)
-> (Key -> Value -> Value) -> Object
forall a b. (a -> b) -> a -> b
$ \Key
k Value
v ->
            if Key
k Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Key
Aeson.fromText Text
fieldName
              then Text -> Value
Aeson.String Text
replacement
              else Value
v
        Value
v -> Value -> m Value
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
      H.evalIO $ LBS.writeFile targetFilePath (Aeson.encodePretty redactedJson)

watchdogProp :: HasCallStack => H.Property -> H.Property
watchdogProp :: HasCallStack => Property -> Property
watchdogProp prop :: Property
prop@Property{PropertyT IO ()
propertyTest :: PropertyT IO ()
propertyTest :: Property -> PropertyT IO ()
propertyTest} = Property
prop{propertyTest = H.runWithWatchdog_ cfg propertyTest}
 where
  cfg :: WatchdogConfig
cfg = H.WatchdogConfig{watchdogTimeout :: Int
H.watchdogTimeout = Int
20}