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

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

import           Cardano.Api

import           Cardano.CLI.Read

import           Control.Concurrent (QSem, newQSem, signalQSem, waitQSem)
import           Control.Exception.Lifted (bracket_)
import           Control.Monad (when)
import           Control.Monad.Base
import           Control.Monad.Catch hiding (bracket_)
import           Control.Monad.Trans.Control (MonadBaseControl)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encode.Pretty as Aeson
import qualified Data.Aeson.Key as Aeson
import qualified Data.Aeson.KeyMap as Aeson
import qualified Data.ByteString.Lazy as LBS
import           Data.Function ((&))
import qualified Data.List as List
import           Data.Monoid (Last (..))
import           Data.Text (Text)
import           GHC.IO.Exception (ExitCode (..))
import           GHC.Stack (CallStack, HasCallStack)
import qualified GHC.Stack as GHC
import qualified System.Directory as IO
import qualified System.Environment as IO
import qualified System.Exit as IO
import           System.FilePath (takeDirectory)
import qualified System.IO.Unsafe as IO
import           System.IO.Unsafe (unsafePerformIO)
import qualified System.Process as IO
import           System.Process (CreateProcess)

import qualified Hedgehog as H
import           Hedgehog.Extras (ExecConfig)
import qualified Hedgehog.Extras as H
import           Hedgehog.Extras.Test (ExecConfig (..))
import           Hedgehog.Internal.Property (Diff, MonadTest, PropertyT, liftTest, mkTest)
import qualified Hedgehog.Internal.Property 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)
  -- ^ Captured stdout
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)
  -- ^ Captured stdout
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 :: * -> *).
(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)
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
  :: [String]
  -- ^ Arguments to the CLI command
  -> H.PropertyT IO (Either H.Failure String)
  -- ^ Captured stdout, or error in case of failures
tryExecCardanoCLI :: [String] -> PropertyT IO (Either Failure String)
tryExecCardanoCLI [String]
args =
  (HasCallStack => [String] -> PropertyT IO String)
-> [String] -> PropertyT IO String
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack (String -> String -> [String] -> PropertyT IO 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 IO String
-> (PropertyT IO String -> TestT (GenT IO) String)
-> TestT (GenT IO) String
forall a b. a -> (a -> b) -> b
& PropertyT IO String -> TestT (GenT IO) String
forall (m :: * -> *) a. PropertyT m a -> TestT (GenT m) a
H.unPropertyT
    TestT (GenT IO) String
-> (TestT (GenT IO) String
    -> ExceptT Failure (WriterT Journal (GenT IO)) String)
-> ExceptT Failure (WriterT Journal (GenT IO)) String
forall a b. a -> (a -> b) -> b
& TestT (GenT IO) String
-> ExceptT Failure (WriterT Journal (GenT IO)) String
forall (m :: * -> *) a.
TestT m a -> ExceptT Failure (WriterT Journal m) a
H.unTest
    ExceptT Failure (WriterT Journal (GenT IO)) String
-> (ExceptT Failure (WriterT Journal (GenT IO)) String
    -> WriterT Journal (GenT IO) (Either Failure String))
-> WriterT Journal (GenT IO) (Either Failure String)
forall a b. a -> (a -> b) -> b
& ExceptT Failure (WriterT Journal (GenT IO)) String
-> WriterT Journal (GenT IO) (Either Failure String)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
    WriterT Journal (GenT IO) (Either Failure String)
-> (WriterT Journal (GenT IO) (Either Failure String)
    -> ExceptT
         Failure (WriterT Journal (GenT IO)) (Either Failure String))
-> ExceptT
     Failure (WriterT Journal (GenT IO)) (Either Failure String)
forall a b. a -> (a -> b) -> b
& WriterT Journal (GenT IO) (Either Failure String)
-> ExceptT
     Failure (WriterT Journal (GenT IO)) (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 IO)) (Either Failure String)
-> (ExceptT
      Failure (WriterT Journal (GenT IO)) (Either Failure String)
    -> TestT (GenT IO) (Either Failure String))
-> TestT (GenT IO) (Either Failure String)
forall a b. a -> (a -> b) -> b
& ExceptT Failure (WriterT Journal (GenT IO)) (Either Failure String)
-> TestT (GenT IO) (Either Failure String)
forall (m :: * -> *) a.
ExceptT Failure (WriterT Journal m) a -> TestT m a
H.TestT
    TestT (GenT IO) (Either Failure String)
-> (TestT (GenT IO) (Either Failure String)
    -> PropertyT IO (Either Failure String))
-> PropertyT IO (Either Failure String)
forall a b. a -> (a -> b) -> b
& TestT (GenT IO) (Either Failure String)
-> PropertyT IO (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 TextEnvelopeCddlError) CddlTx
r <- IO (Either (FileError TextEnvelopeCddlError) CddlTx)
-> m (Either (FileError TextEnvelopeCddlError) CddlTx)
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO (Either (FileError TextEnvelopeCddlError) CddlTx)
 -> m (Either (FileError TextEnvelopeCddlError) CddlTx))
-> IO (Either (FileError TextEnvelopeCddlError) CddlTx)
-> m (Either (FileError TextEnvelopeCddlError) CddlTx)
forall a b. (a -> b) -> a -> b
$ FileOrPipe -> IO (Either (FileError TextEnvelopeCddlError) CddlTx)
readCddlTx FileOrPipe
reference
      Either (FileError TextEnvelopeCddlError) CddlTx
c <- IO (Either (FileError TextEnvelopeCddlError) CddlTx)
-> m (Either (FileError TextEnvelopeCddlError) CddlTx)
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO (Either (FileError TextEnvelopeCddlError) CddlTx)
 -> m (Either (FileError TextEnvelopeCddlError) CddlTx))
-> IO (Either (FileError TextEnvelopeCddlError) CddlTx)
-> m (Either (FileError TextEnvelopeCddlError) CddlTx)
forall a b. (a -> b) -> a -> b
$ FileOrPipe -> IO (Either (FileError TextEnvelopeCddlError) CddlTx)
readCddlTx FileOrPipe
created
      Either (FileError TextEnvelopeCddlError) CddlTx
r Either (FileError TextEnvelopeCddlError) CddlTx
-> Either (FileError TextEnvelopeCddlError) CddlTx -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
H.=== Either (FileError TextEnvelopeCddlError) CddlTx
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 IO () -> H.Property
propertyOnce :: PropertyT IO () -> Property
propertyOnce = TestLimit -> Property -> Property
H.withTests TestLimit
1 (Property -> Property)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShrinkLimit -> Property -> Property
H.withShrinks ShrinkLimit
0 (Property -> Property)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
H.property

-- | 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)

-- | A file semaphore protecting against a concurrent path access
data FileSem = FileSem !FilePath !QSem

instance Show FileSem where
  show :: FileSem -> String
show (FileSem String
path QSem
_) = String
"FileSem " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path

deriving via (ShowOf FileSem) instance Pretty FileSem

-- | Create new file semaphore. Always use with @NOINLINE@ pragma! Example:
-- @
-- createTestnetDataOutSem :: FileSem
-- createTestnetDataOutSem = newFileSem "test/cardano-cli-golden/files/golden/conway/create-testnet-data.out"
-- {-# NOINLINE createTestnetDataOutSem  #-}
-- @
newFileSem
  :: FilePath
  -- ^ path to be guarded by a semaphore allowing only one concurrent to access it
  -> FileSem
newFileSem :: String -> FileSem
newFileSem String
fp = IO FileSem -> FileSem
forall a. IO a -> a
unsafePerformIO (IO FileSem -> FileSem) -> IO FileSem -> FileSem
forall a b. (a -> b) -> a -> b
$ String -> QSem -> FileSem
FileSem String
fp (QSem -> FileSem) -> IO QSem -> IO FileSem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO QSem
newQSem Int
1
{-# INLINE newFileSem #-}

-- | Run action acquiring a semaphore, and releasing afterwards. Guards against concurrent access to
-- a block of code.
bracketSem
  :: MonadBaseControl IO m
  => FileSem
  -- ^ a file semaphore
  -> (FilePath -> m c)
  -- ^ an action, a file path will be extracted from the semaphore
  -> m c
bracketSem :: forall (m :: * -> *) c.
MonadBaseControl IO m =>
FileSem -> (String -> m c) -> m c
bracketSem (FileSem String
path QSem
semaphore) String -> m c
act =
  m () -> m () -> m c -> m c
forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> m b -> m c -> m c
bracket_ (IO () -> m ()
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ QSem -> IO ()
waitQSem QSem
semaphore) (IO () -> m ()
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ QSem -> IO ()
signalQSem QSem
semaphore) (m c -> m c) -> m c -> m c
forall a b. (a -> b) -> a -> b
$
    String -> m c
act String
path

-- | Invert the behavior of a MonadTest: success becomes failure and vice versa.
expectFailure :: HasCallStack => H.TestT IO m -> PropertyT IO ()
expectFailure :: forall m. HasCallStack => TestT IO m -> PropertyT IO ()
expectFailure TestT IO m
prop = (HasCallStack => PropertyT IO ()) -> PropertyT IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => PropertyT IO ()) -> PropertyT IO ())
-> (HasCallStack => PropertyT IO ()) -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ do
  (Either Failure m
res, Journal
_) <- IO (Either Failure m, Journal)
-> PropertyT IO (Either Failure m, Journal)
forall (m :: * -> *) a.
(MonadTest m, MonadIO m, HasCallStack) =>
IO a -> m a
H.evalIO (IO (Either Failure m, Journal)
 -> PropertyT IO (Either Failure m, Journal))
-> IO (Either Failure m, Journal)
-> PropertyT IO (Either Failure m, Journal)
forall a b. (a -> b) -> a -> b
$ TestT IO m -> IO (Either Failure m, Journal)
forall (m :: * -> *) a. TestT m a -> m (Either Failure a, Journal)
H.runTestT TestT IO m
prop
  case Either Failure m
res of
    Left Failure
_ -> () -> PropertyT IO ()
forall a. a -> PropertyT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- Property failed so we succeed
    Either Failure m
_ -> Maybe Diff -> String -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> String -> m a
H.failWith Maybe Diff
forall a. Maybe a
Nothing String
"Expected the test to fail but it passed" -- Property passed but we expected a failure