{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Convex.Devnet.Utils(
  withLogFile,
  checkProcessHasNotDied,
  failure,
  defaultNetworkId,
  readConfigFile,
  createSystemTempDirectory,
  withTempDir,
  failAfter,
  keysFor
) where

import           Cardano.Api                       (AsType, NetworkId,
                                                    PaymentKey, SigningKey,
                                                    VerificationKey)
import qualified Cardano.Api                       as C
import           Control.Exception                 (catch, onException)
import           Control.Monad.Class.MonadThrow    (MonadThrow, throwIO)
import           Control.Monad.Class.MonadTimer.SI (DiffTime, MonadTimer,
                                                    timeout)
import           Control.Monad.IO.Class            (MonadIO (..))
import qualified Data.Aeson                        as Aeson
import           Data.Bifunctor                    (Bifunctor (..))
import           Data.ByteString                   (ByteString)
import qualified Data.ByteString                   as BS
import           Data.Proxy                        (Proxy (..))
import           Data.Text                         (Text)
import           Data.Void                         (Void)
import           GHC.IO.Exception                  (IOErrorType (UnsatisfiedConstraints),
                                                    ioe_type)
import           GHC.Stack                         (HasCallStack, SrcLoc,
                                                    callStack, getCallStack)
import qualified Paths_convex_devnet               as Pkg
import           System.Directory                  (createDirectoryIfMissing,
                                                    removePathForcibly)
import           System.Exit                       (ExitCode (..))
import           System.FilePath                   (takeDirectory, (<.>), (</>))
import           System.Info                       (os)
import           System.IO                         (BufferMode (NoBuffering),
                                                    Handle, IOMode (AppendMode),
                                                    hSetBuffering, withFile)
import           System.IO.Temp                    (createTempDirectory,
                                                    getCanonicalTemporaryDirectory)
import           System.Process                    (ProcessHandle,
                                                    waitForProcess)
import           Test.HUnit.Lang                   (FailureReason (Reason),
                                                    HUnitFailure (HUnitFailure))

import           Prelude

-- | Read keys form a file
keysFor :: String -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor :: String -> IO (VerificationKey PaymentKey, SigningKey PaymentKey)
keysFor String
actor = do
  ByteString
bs <- String -> IO ByteString
readConfigFile (String
"credentials" String -> String -> String
</> String
actor String -> String -> String
<.> String
"sk")
  let res :: Either TextEnvelopeError (SigningKey PaymentKey)
res =
        forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> TextEnvelopeError
C.TextEnvelopeAesonDecodeError (forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecodeStrict ByteString
bs)
          forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a.
HasTextEnvelope a =>
AsType a -> TextEnvelope -> Either TextEnvelopeError a
C.deserialiseFromTextEnvelope AsType (SigningKey PaymentKey)
asSigningKey
  case Either TextEnvelopeError (SigningKey PaymentKey)
res of
    Left TextEnvelopeError
err ->
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"cannot decode text envelope from '" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ByteString
bs forall a. Semigroup a => a -> a -> a
<> String
"', error: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show TextEnvelopeError
err
    Right SigningKey PaymentKey
sk -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall keyrole.
Key keyrole =>
SigningKey keyrole -> VerificationKey keyrole
C.getVerificationKey SigningKey PaymentKey
sk, SigningKey PaymentKey
sk)
 where
  asSigningKey :: AsType (SigningKey PaymentKey)
  asSigningKey :: AsType (SigningKey PaymentKey)
asSigningKey = forall t. HasTypeProxy t => Proxy t -> AsType t
C.proxyToAsType forall {k} (t :: k). Proxy t
Proxy

-- | Open given log file non-buffered in append mode and print a message with
-- filepath to @stderr@ on exceptions.
withLogFile :: FilePath -> (Handle -> IO a) -> IO a
withLogFile :: forall a. String -> (Handle -> IO a) -> IO a
withLogFile String
filepath Handle -> IO a
io = do
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> String
takeDirectory String
filepath)
  forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
filepath IOMode
AppendMode (\Handle
out -> Handle -> BufferMode -> IO ()
hSetBuffering Handle
out BufferMode
NoBuffering forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO a
io Handle
out)
    forall a b. IO a -> IO b -> IO a
`onException` String -> IO ()
putStrLn (String
"Logfile written to: " forall a. Semigroup a => a -> a -> a
<> String
filepath)

-- | Create a unique temporary directory.
createSystemTempDirectory :: String -> IO FilePath
createSystemTempDirectory :: String -> IO String
createSystemTempDirectory String
template = do
  String
tmpDir <- case String
os of
    String
"darwin" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"/tmp" -- https://github.com/input-output-hk/hydra/issues/158.
    String
_        -> IO String
getCanonicalTemporaryDirectory
  String -> String -> IO String
createTempDirectory String
tmpDir String
template

-- | Create a temporary directory for the given 'action' to use.
-- The directory is removed if and only if the action completes successfuly.
withTempDir :: MonadIO m => String -> (FilePath -> m r) -> m r
withTempDir :: forall (m :: * -> *) r.
MonadIO m =>
String -> (String -> m r) -> m r
withTempDir String
baseName String -> m r
action = do
  String
tmpDir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO String
createSystemTempDirectory String
baseName
  r
res <- String -> m r
action String
tmpDir
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Word -> String -> IO ()
cleanup Word
0 String
tmpDir
  forall (f :: * -> *) a. Applicative f => a -> f a
pure r
res
 where
  -- NOTE: Somehow, since 1.35.0, cleaning-up cardano-node database directory
  -- _sometimes_ generates an empty 'clean' file which prevents the 'db' folder
  -- to be fully removed and triggers an 'UnsatisfiedConstraints' IOException.
  cleanup :: Word -> String -> IO ()
cleanup (Word
maxAttempts :: Word) String
dir =
    String -> IO ()
removePathForcibly String
dir
      forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` ( \IOException
e -> case IOException -> IOErrorType
ioe_type IOException
e of
                  IOErrorType
UnsatisfiedConstraints ->
                    if Word
maxAttempts forall a. Ord a => a -> a -> Bool
< Word
3 then Word -> String -> IO ()
cleanup (forall a. Enum a => a -> a
succ Word
maxAttempts) String
dir else forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e
                  IOErrorType
_ ->
                    forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO IOException
e
              )

-- | Wait for process termination and do 'failure' on non-zero exit code.
-- This function is useful for end-to-end testing of external processes esp. in
-- conjunction with 'race' combinator:
--
-- @@
-- withCreateProcess p $
--   \_stdin _stdout _stderr processHandle -> do
--       race_
--         (checkProcessHasNotDied "my-process" processHandle)
--         doStuff
-- @@
checkProcessHasNotDied :: Text -> ProcessHandle -> IO Void
checkProcessHasNotDied :: Text -> ProcessHandle -> IO Void
checkProcessHasNotDied Text
name ProcessHandle
processHandle =
  ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
processHandle forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ExitCode
ExitSuccess -> forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
"Process has died"
    ExitFailure Int
exit -> forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure forall a b. (a -> b) -> a -> b
$ String
"Process " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Text
name forall a. Semigroup a => a -> a -> a
<> String
" exited with failure code: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
exit

-- | Fails a test with given error message.
-- This function improves over existing 'expectationFailure' by throwing a
-- 'HUnitFailure' exception containig the location of the error and providing
-- better callstack context.
failure :: (HasCallStack, MonadThrow m) => String -> m a
failure :: forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure String
msg =
  forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (Maybe SrcLoc -> FailureReason -> HUnitFailure
HUnitFailure HasCallStack => Maybe SrcLoc
location forall a b. (a -> b) -> a -> b
$ String -> FailureReason
Reason String
msg)

-- | Provides the source code location where this function is called.
-- This relies on the <https://hackage.haskell.org/package/base-4.15.0.0/docs/GHC-Exception.html#t:CallStack CallStack>
-- information provided by GHC and to be useful requires all functions to be properly
-- annotated.
location :: HasCallStack => Maybe SrcLoc
location :: HasCallStack => Maybe SrcLoc
location = case forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ CallStack -> [(String, SrcLoc)]
getCallStack HasCallStack => CallStack
callStack of
  (String
_, SrcLoc
loc) : [(String, SrcLoc)]
_ -> forall a. a -> Maybe a
Just SrcLoc
loc
  [(String, SrcLoc)]
_            -> forall a. Maybe a
Nothing

defaultNetworkId :: NetworkId
defaultNetworkId :: NetworkId
defaultNetworkId = NetworkMagic -> NetworkId
C.Testnet (Word32 -> NetworkMagic
C.NetworkMagic Word32
42)

-- | Lookup a config file similar reading a file from disk.
readConfigFile :: FilePath -> IO ByteString
readConfigFile :: String -> IO ByteString
readConfigFile String
source = do
  String
filename <- String -> IO String
Pkg.getDataFileName (String
"config" String -> String -> String
</> String
source)
  String -> IO ByteString
BS.readFile String
filename

-- | Fail some monadic action if it does not complete within given timeout.
-- A 'DiffTime' can be represented as a decimal number of seconds.
failAfter :: (HasCallStack, MonadTimer m, MonadThrow m) => DiffTime -> m a -> m a
failAfter :: forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
DiffTime -> m a -> m a
failAfter DiffTime
seconds m a
action =
  forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout DiffTime
seconds m a
action forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe a
Nothing -> forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
failure forall a b. (a -> b) -> a -> b
$ String
"Test timed out after " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show DiffTime
seconds forall a. Semigroup a => a -> a -> a
<> String
" seconds"
    Just a
a  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a