{-# 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 (when)
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 Data.Text (Text)
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
  [(String, String)]
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
  (ExitCode, String, String)
result <-
    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
        { H.execConfigEnv = Last $ Just (envVars ++ env)
        }
      [String]
args
  case (ExitCode, String, String)
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
  String
bin <- String -> String -> m String
forall (m :: * -> *).
(HasCallStack, MonadTest m, MonadIO m) =>
String -> String -> m String
H.binFlex String
pkg String
binaryEnv
  CreateProcess -> m CreateProcess
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    (String -> [String] -> CreateProcess
IO.proc String
bin [String]
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
  CreateProcess
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
  String -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.annotate (String -> m ()) -> (String -> String) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Command: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ case CreateProcess -> CmdSpec
IO.cmdspec CreateProcess
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
  IO (ExitCode, String, String) -> m (ExitCode, String, String)
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO (ExitCode, String, String) -> m (ExitCode, String, String))
-> IO (ExitCode, String, String) -> m (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ CreateProcess -> String -> IO (ExitCode, String, String)
IO.readCreateProcessWithExitCode CreateProcess
cp String
""

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
  -> FilePath
  -> 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
  Either (FileError TextEnvelopeError) TextEnvelope
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
  TextEnvelope
refTextEnvelope <- Either (FileError TextEnvelopeError) TextEnvelope -> m TextEnvelope
forall (m :: * -> *).
MonadTest m =>
Either (FileError TextEnvelopeError) TextEnvelope -> m TextEnvelope
handleTextEnvelope Either (FileError TextEnvelopeError) TextEnvelope
eRefTextEnvelope

  Either (FileError TextEnvelopeError) TextEnvelope
eCreatedTextEnvelope <- 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
created
  TextEnvelope
createdTextEnvelope <- Either (FileError TextEnvelopeError) TextEnvelope -> m TextEnvelope
forall (m :: * -> *).
MonadTest m =>
Either (FileError TextEnvelopeError) TextEnvelope -> m TextEnvelope
handleTextEnvelope Either (FileError TextEnvelopeError) TextEnvelope
eCreatedTextEnvelope

  TextEnvelope -> TextEnvelope -> m ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
TextEnvelope -> TextEnvelope -> m ()
typeTitleEquivalence TextEnvelope
refTextEnvelope TextEnvelope
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

  typeTitleEquivalence :: (MonadTest m, HasCallStack) => TextEnvelope -> TextEnvelope -> m ()
  typeTitleEquivalence :: forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
TextEnvelope -> TextEnvelope -> m ()
typeTitleEquivalence
    (TextEnvelope TextEnvelopeType
refType 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
      TextEnvelopeType -> TextEnvelopeType -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
equivalence TextEnvelopeType
refType TextEnvelopeType
createdType
      TextEnvelopeDescr -> TextEnvelopeDescr -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
equivalence TextEnvelopeDescr
refTitle TextEnvelopeDescr
createdTitle

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
  Bool
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 Bool
fileExists
    then do
      FileOrPipe
reference <- IO FileOrPipe -> m FileOrPipe
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO FileOrPipe -> m FileOrPipe) -> IO FileOrPipe -> m FileOrPipe
forall a b. (a -> b) -> a -> b
$ String -> IO FileOrPipe
fileOrPipe String
referencePath
      FileOrPipe
created <- IO FileOrPipe -> m FileOrPipe
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO FileOrPipe -> m FileOrPipe) -> IO FileOrPipe -> m FileOrPipe
forall a b. (a -> b) -> a -> b
$ String -> IO FileOrPipe
fileOrPipe String
createdPath
      Either (FileError TextEnvelopeError) (InAnyShelleyBasedEra Tx)
r <- IO (Either (FileError TextEnvelopeError) (InAnyShelleyBasedEra Tx))
-> m (Either
        (FileError TextEnvelopeError) (InAnyShelleyBasedEra Tx))
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO
   (Either (FileError TextEnvelopeError) (InAnyShelleyBasedEra Tx))
 -> m (Either
         (FileError TextEnvelopeError) (InAnyShelleyBasedEra Tx)))
-> IO
     (Either (FileError TextEnvelopeError) (InAnyShelleyBasedEra Tx))
-> m (Either
        (FileError TextEnvelopeError) (InAnyShelleyBasedEra Tx))
forall a b. (a -> b) -> a -> b
$ FileOrPipe
-> IO
     (Either (FileError TextEnvelopeError) (InAnyShelleyBasedEra Tx))
readTx FileOrPipe
reference
      Either (FileError TextEnvelopeError) (InAnyShelleyBasedEra Tx)
c <- IO (Either (FileError TextEnvelopeError) (InAnyShelleyBasedEra Tx))
-> m (Either
        (FileError TextEnvelopeError) (InAnyShelleyBasedEra Tx))
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO
   (Either (FileError TextEnvelopeError) (InAnyShelleyBasedEra Tx))
 -> m (Either
         (FileError TextEnvelopeError) (InAnyShelleyBasedEra Tx)))
-> IO
     (Either (FileError TextEnvelopeError) (InAnyShelleyBasedEra Tx))
-> m (Either
        (FileError TextEnvelopeError) (InAnyShelleyBasedEra Tx))
forall a b. (a -> b) -> a -> b
$ FileOrPipe
-> IO
     (Either (FileError TextEnvelopeError) (InAnyShelleyBasedEra Tx))
readTx FileOrPipe
created
      Either (FileError TextEnvelopeError) (InAnyShelleyBasedEra Tx)
r Either (FileError TextEnvelopeError) (InAnyShelleyBasedEra Tx)
-> Either (FileError TextEnvelopeError) (InAnyShelleyBasedEra Tx)
-> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
H.=== Either (FileError TextEnvelopeError) (InAnyShelleyBasedEra Tx)
c
    else
      if Bool
createFiles
        then do
          -- CREATE_GOLDEN_FILES is set, so we create any golden files that don't
          -- already exist.
          String -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.note_ (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Creating golden file " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
referencePath
          String -> m ()
forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
String -> m ()
H.createDirectoryIfMissing_ (String -> String
takeDirectory String
referencePath)
          String -> m String
forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
String -> m String
H.readFile String
createdPath m String -> (String -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> String -> m ()
forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
String -> String -> m ()
H.writeFile String
referencePath
        else do
          String -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
H.note_ (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
            [String] -> String
forall a. Monoid a => [a] -> a
mconcat
              [ String
"Golden file " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
referencePath
              , String
" does not exist.  To create, run with CREATE_GOLDEN_FILES=1"
              ]
          m ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
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
  Maybe String
value <- String -> IO (Maybe String)
IO.lookupEnv String
"CREATE_GOLDEN_FILES"
  Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Maybe String
value Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
"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
  Bool
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
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (m () -> m ()) -> 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
H.failWithCustom CallStack
HasCallStack => CallStack
GHC.callStack Maybe Diff
forall a. Maybe a
Nothing (String
dir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" 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
  Bool
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 Bool
ok
    then m ()
forall (m :: * -> *). MonadTest m => m ()
H.success
    else CallStack -> a -> a -> m ()
forall (m :: * -> *) a.
(MonadTest m, Show a) =>
CallStack -> a -> a -> m ()
failDiffCustom CallStack
HasCallStack => CallStack
GHC.callStack a
x a
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
  ByteString
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 ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode ByteString
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
      Value
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
      IO () -> m ()
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
LBS.writeFile String
targetFilePath (Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encodePretty Value
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}