Client.hs

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

-- | Implementation that works with real Tezos network, it
-- talks to a Tezos node and uses @tezos-client@.

module Test.Cleveland.Internal.Client
  ( ClientM (..)
  , runClevelandT

  -- * Capability implementations
  , networkOpsImpl
  , networkMiscImpl

  -- * Internals
  , revealKeyUnlessRevealed
  , setupMoneybagAddress
  , ClientState(..)
  , TestError(..)
  , MoneybagConfigurationException (..)

  -- * Environment
  , NetworkEnv (..)
  , mkMorleyOnlyRpcEnvNetwork

  -- * Lens for 'NetworkEnv'
  , neMorleyClientEnvL
  , neSecretKeyL
  , neMoneybagAliasL
  , neExplicitDataDirL

  -- * Error types
  , InternalNetworkScenarioError(..)
  ) where

import Control.Lens (_head, each, filtered, makeLensesWith)
import Data.Aeson.Text qualified as J
import Data.Constraint (withDict, (\\))
import Data.Default (def)
import Data.Ratio ((%))
import Data.Set qualified as Set
import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, secondsToNominalDiffTime)
import Fmt (Buildable(build), Builder, indentF, pretty, unlinesF, (+|), (|+))
import System.IO (hFlush)
import Time (KnownDivRat, Second, Time, sec, threadDelay, toNum, toUnit)
import Unsafe qualified (fromIntegral)

import Lorentz (NicePackedValue, toAddress)
import Lorentz qualified as L
import Lorentz.Constraints.Scopes (NiceUnpackedValue, niceParameterEvi)
import Morley.AsRPC (AsRPC, HasRPCRepr(..), MaybeRPC(..), TAsRPC, notesAsRPC, rpcSingIEvi)
import Morley.Client (MorleyClientEnv, OperationInfo(..), disableAlphanetWarning, runMorleyClientM)
import Morley.Client qualified as Client
import Morley.Client.Action (Result)
import Morley.Client.Action.Reveal qualified as RevealRPC
import Morley.Client.Init qualified as Client
import Morley.Client.Logging (logInfo, logWarning)
import Morley.Client.RPC.Error qualified as RPC (ClientRpcError(..), RunCodeErrors(..))
import Morley.Client.RPC.Types
  (AppliedResult(..), BlockConstants(bcHeader), BlockHeaderNoHash(bhnhLevel, bhnhTimestamp),
  BlockId(..), OperationHash, OriginationScript(..),
  ProtocolParameters(ProtocolParameters, ppCostPerByte, ppMinimalBlockDelay, ppOriginationSize))
import Morley.Client.TezosClient.Types (tceMbTezosClientDataDirL)
import Morley.Client.Util qualified as Client
import Morley.Micheline
  (Expression, MichelinePrimitive(..), StringEncode(..), TezosInt64, TezosMutez(..),
  _ExpressionPrim, _ExpressionSeq, fromExpression, mpaArgsL, mpaPrimL)
import Morley.Michelson.TypeCheck (typeCheckContractAndStorage, typeCheckingWith)
import Morley.Michelson.Typed (BigMapId, SomeAnnotatedValue(..), SomeContractAndStorage(..), toVal)
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Untyped qualified as U
import Morley.Tezos.Address (Address, mkKeyAddress)
import Morley.Tezos.Address.Alias (AddressOrAlias(..))
import Morley.Tezos.Core as Tezos
  (Mutez, Timestamp(..), addMutez, subMutez, timestampFromUTCTime, unsafeAddMutez, unsafeMulMutez,
  unsafeSubMutez)
import Morley.Tezos.Crypto
import Morley.Tezos.Crypto qualified as Crypto
import Morley.Util.Exception
import Morley.Util.Lens (postfixLFields)
import Morley.Util.Named
import Test.Cleveland.Internal.Abstract
import Test.Cleveland.Internal.Exceptions (addCallStack)
import Test.Cleveland.Util (ceilingUnit)

data NetworkEnv = NetworkEnv
  { neMorleyClientEnv :: MorleyClientEnv
  , neSecretKey :: Maybe Crypto.SecretKey
  , neMoneybagAlias :: Alias
  , neExplicitDataDir :: Bool
  }

makeLensesWith postfixLFields ''NetworkEnv

-- | Construct 'Client.MorleyOnlyRpcEnv' from 'NetworkEnv'.
mkMorleyOnlyRpcEnvNetwork
  :: NetworkEnv
  -> [SecretKey]  -- ^ Extra secrets that should be known
  -> Client.MorleyOnlyRpcEnv
mkMorleyOnlyRpcEnvNetwork NetworkEnv{..} extraSecrets =
  Client.MorleyOnlyRpcEnv
  { moreLogAction = Client.mkLogAction 0
  , moreClientEnv = Client.mceClientEnv neMorleyClientEnv
  , moreSecretKeys = mconcat
      [ one (mkKeyAddress (toPublic sk), sk)
      | sk <- maybe id (:) neSecretKey extraSecrets ]
  }

-- | This error designates that necessary preparations for running tests
-- are not made.
data MoneybagConfigurationException
  = NoMoneybagAddress Alias
  | TwoMoneybagKeys Alias SecretKey Address
  deriving stock (Generic, Show, Eq)

instance Buildable MoneybagConfigurationException where
  build = \case
    NoMoneybagAddress alias -> unlinesF @_ @Builder
      [ "Moneybag alias is not registered in the tezos node: " <> build alias
      , ""
      , "Cleveland's network tests require a special address with plenty of XTZ for"
      , "originating contracts and performing transfers."
      , ""
      , "By default, Cleveland expects an account with the alias 'moneybag' to already exist."
      , "If no such alias exists, you can choose to either:"
      , "  * Use a different alias, supplied via '--cleveland-moneybag-alias'."
      , "  * Import a moneybag account, by supplying its secret key via '--cleveland-moneybag-secret-key'."
      ]
    TwoMoneybagKeys alias envKey existingAddress -> unlinesF @_ @Builder
      [ "Tried to import the secret key supplied via '--cleveland-moneybag-secret-key' and"
      , "associate it with the alias '" +| alias |+ "', but the alias already exists."
      , ""
      , "  --cleveland-moneybag-secret-key: " <> build envKey
      , "  Existing address             : " <> build existingAddress
      , ""
      , "Possible fix:"
      , "  * If you wish to use the existing address, please remove the '--cleveland-moneybag-secret-key' option."
      , "  * Otherwise, please supply a different alias via '--cleveland-moneybag-alias'."
      ]


instance Exception MoneybagConfigurationException where
  displayException = pretty

data ClientState = ClientState
  { csDefaultAliasCounter :: DefaultAliasCounter
  , csRefillableAddresses :: Set Address
  , csMoneybagAddress :: Moneybag
  }

newtype ClientM a = ClientM
  { unClientM :: ReaderT (IORef ClientState) IO a
  }
  deriving newtype (Functor, Applicative, Monad, MonadIO,
                    MonadThrow, MonadCatch, MonadReader (IORef ClientState), MonadFail)

data InternalNetworkScenarioError = TooManyRefillIterations Word Address
  deriving stock (Show)

instance Buildable InternalNetworkScenarioError where
  build (TooManyRefillIterations iter addr) =
    "Too many (" +| iter |+ ") refill iteratons of " +| addr |+ ""

instance Exception InternalNetworkScenarioError where
  displayException = pretty

runClevelandT :: NetworkEnv -> ClevelandT ClientM a -> IO a
runClevelandT env scenario = do
  disableAlphanetWarning
  moneybagAddr <- setupMoneybagAddress env
  let caps = ClevelandCaps
        { ccSender = Sender $ unMoneybag moneybagAddr
        , ccMoneybag = moneybagAddr
        , ccMiscCap = networkMiscImpl (neMorleyClientEnv env)
        , ccOpsCap = networkOpsImpl (neMorleyClientEnv env)
        }
  ist <- newIORef ClientState
    { csDefaultAliasCounter = DefaultAliasCounter 0
    , csRefillableAddresses = Set.empty
    , csMoneybagAddress = moneybagAddr
    }
  let clientM = runReaderT scenario caps
  runReaderT (unClientM clientM) ist

-- | Initialize @moneybag@ address by given 'NetworkEnv'
setupMoneybagAddress :: NetworkEnv -> IO Moneybag
setupMoneybagAddress NetworkEnv{..} = do
  let setupEnv = neMorleyClientEnv &
        if neExplicitDataDir
        then id
        else Client.mceTezosClientL . tceMbTezosClientDataDirL .~ Nothing
  storageAddress <- runMorleyClientM setupEnv $
    Client.resolveAddressMaybe (AddressAlias neMoneybagAlias)
  Moneybag <$> case (neSecretKey, storageAddress) of
    (Nothing, Just addr) -> do
      unless neExplicitDataDir do
        ek <- runMorleyClientM setupEnv $
          Client.getSecretKey (AddressAlias neMoneybagAlias)
        void $ runMorleyClientM neMorleyClientEnv $
          Client.importKey False neMoneybagAlias ek
      pure addr
    (Nothing, Nothing) -> throwM $ NoMoneybagAddress neMoneybagAlias
    (Just ek, Just sa)
      | mkKeyAddress (toPublic ek) == sa -> do
          unless neExplicitDataDir $ void $
            runMorleyClientM neMorleyClientEnv $
              Client.importKey False neMoneybagAlias ek
          pure sa
      | otherwise -> throwM $ TwoMoneybagKeys neMoneybagAlias ek sa
    (Just ek, Nothing) -> do
      runMorleyClientM neMorleyClientEnv $
        Client.importKey False neMoneybagAlias ek
      return $ mkKeyAddress (toPublic ek)

-- | Implementation that works with real network and uses @tezos-node@
-- RPC and @tezos-client@.
networkOpsImpl :: MorleyClientEnv -> Sender -> ClevelandOpsImpl ClientM
networkOpsImpl env (Sender sender) =
  mapClevelandOpsImplExceptions (addCallStack . exceptionHandler)
    ClevelandOpsImpl
    { coiRunOperationBatch = runOperationBatch env sender
    }

networkMiscImpl :: MorleyClientEnv -> ClevelandMiscImpl ClientM
networkMiscImpl env = mapClevelandMiscImplExceptions (addCallStack . exceptionHandler)
  ClevelandMiscImpl
    { cmiRunIO = liftIO

    , cmiOriginateLargeUntyped = \sender untypedOriginateData -> do
        (_, res) <- runClientOrigination env
          sender Client.originateLargeUntypedContract untypedOriginateData
        comment $
          "Originated large smart contract " +| uodName untypedOriginateData |+
          " with address " <> pretty res
        pure res

    , cmiSignBytes = \hash signer -> liftIO $ runMorleyClientM env $
        -- We don't use password protected accounts in cleveland tests
        Client.signBytes (AddressResolved signer) Nothing hash

    , cmiGenKey = \sodAlias -> do
        alias <- resolveSpecificOrDefaultAlias sodAlias
        liftIO $ runMorleyClientM env $ Client.genKey alias

    , cmiGenFreshKey = \sodAlias -> do
        alias <- resolveSpecificOrDefaultAlias sodAlias
        liftIO $ runMorleyClientM env $ Client.genFreshKey alias

    , cmiGetBalance = getBalanceHelper
    , cmiGetChainId = liftIO $ runMorleyClientM env Client.getChainId
    , cmiAttempt = try
    , cmiThrow = throwM
    , cmiMarkAddressRefillable = setAddressRefillable
    , cmiRegisterDelegate = \addr -> liftIO $ runMorleyClientM env $ do
        alias <- Client.getAlias (AddressResolved addr)
        Client.registerDelegate alias Nothing
    , cmiComment = comment
    , cmiEmulatedImpl = pure Nothing
    , ..
    }
  where
    cmiFailure :: Builder -> ClientM a
    cmiFailure = throwM . CustomTestError . pretty

    cmiGetBigMapValueMaybe :: (NicePackedValue k, NiceUnpackedValue v) => BigMapId k v -> k -> ClientM (Maybe v)
    cmiGetBigMapValueMaybe bigMapId k =
      liftIO . runMorleyClientM env $ Client.readBigMapValueMaybe bigMapId k

    cmiGetAllBigMapValuesMaybe :: (NiceUnpackedValue v) => BigMapId k v -> ClientM (Maybe [v])
    cmiGetAllBigMapValuesMaybe bigMapId =
      liftIO . runMorleyClientM env $ Client.readAllBigMapValuesMaybe bigMapId

    getStorageType :: Expression -> ClientM U.Ty
    getStorageType contractExpr = do
      let
        storageTypeExprMb = contractExpr ^?
          _ExpressionSeq
          . each
          . _ExpressionPrim
          . filtered (\prim -> prim ^. mpaPrimL == MichelinePrimitive "storage")
          . mpaArgsL
          . _head

      case storageTypeExprMb of
        Nothing -> cmiFailure $ unlinesF
          [ "Contract expression did not contain a 'storage' expression."
          , "Contract expression:"
          , indentF 2 $ build (J.encodeToTextBuilder contractExpr)
          ]
        Just storageTypeExpr ->
          case fromExpression @U.Ty storageTypeExpr of
            Left err -> cmiFailure $ unlinesF
              [ "'storage' expression was not a valid type expression."
              , "Storage expression:"
              , indentF 2 $ build (J.encodeToTextBuilder storageTypeExpr)
              , "Decoding error:"
              , indentF 2 $ build err
              ]
            Right storageType -> pure storageType

    cmiGetSomeStorage :: Address -> ClientM SomeAnnotatedValue
    cmiGetSomeStorage addr = do
      OriginationScript {osCode, osStorage} <- liftIO . runMorleyClientM env $ Client.getContractScript addr
      storageType <- getStorageType osCode
      T.withUType storageType \(storageNotes :: T.Notes t) -> do
        withDict (rpcSingIEvi @t) do
          case fromExpression @(T.Value (TAsRPC t)) osStorage of
            Right storageValueRPC ->
              pure $ SomeAnnotatedValue (notesAsRPC storageNotes) storageValueRPC
            Left err ->
              cmiFailure $ unlinesF
                [ "Failed to decode storage expression."
                , "Storage expression:"
                , indentF 2 $ build (J.encodeToTextBuilder osStorage)
                , "Decoding error:"
                , indentF 2 $ build err
                ]

    cmiResolveAddress :: Alias -> ClientM Address
    cmiResolveAddress = liftIO . runMorleyClientM env . Client.resolveAddress . AddressAlias

    cmiGetPublicKey :: Address -> ClientM PublicKey
    cmiGetPublicKey = liftIO . runMorleyClientM env . Client.getPublicKey . AddressResolved

    getBalanceHelper :: Address -> ClientM Mutez
    getBalanceHelper = liftIO . runMorleyClientM env . Client.getBalance

    cmiGetDelegate :: Address -> ClientM (Maybe KeyHash)
    cmiGetDelegate = liftIO . runMorleyClientM env . Client.getDelegate

    cmiGetNow :: ClientM Tezos.Timestamp
    cmiGetNow = timestampFromUTCTime <$> getLastBlockTimestamp env

    cmiGetLevel :: ClientM Natural
    cmiGetLevel = getLastBlockLevel env

    cmiGetApproximateBlockInterval :: ClientM (Time Second)
    cmiGetApproximateBlockInterval = liftIO $ do
      pp <- runMorleyClientM env $ Client.getProtocolParameters
      return . sec $ (unStringEncode $ ppMinimalBlockDelay pp) % 1

    cmiAdvanceTime :: (KnownDivRat unit Second) => Time unit -> ClientM ()
    cmiAdvanceTime delta = do
      let
        -- Round 'delta' to the nearest second, not smaller than 'delta'.
        -- A chain's time resolution is never smaller than a second,
        -- so if 'delta' is 0.1s, we actually need to wait at least 1s.
        deltaSec :: Time Second
        deltaSec = ceilingUnit $ toUnit @Second delta

        deltaSec' :: NominalDiffTime
        deltaSec' = secondsToNominalDiffTime $ toNum @Second deltaSec
      t0 <- getLastBlockTimestamp env
      threadDelay deltaSec
      let
        go :: ClientM ()
        go = do
          now <- getLastBlockTimestamp env
          if (now `diffUTCTime` t0) >= deltaSec'
            then pass
            else threadDelay (sec 1) >> go
      go

    cmiAdvanceToLevel :: (Natural -> Natural) -> ClientM ()
    cmiAdvanceToLevel targetLevelFn = do
      lastLevel <- getLastBlockLevel env
      let targetLevel = max (targetLevelFn lastLevel) lastLevel
      let skippedLevels = targetLevel - lastLevel
      -- In case we need to skip more than one level we'll jump ahead for
      -- 'cmiGetApproximateBlockInterval' for 'skippedLevels - 1' times.
      -- This way we are sure we won't end up in the middle (or towards the end)
      -- of the target level.
      when (skippedLevels > 0) $ do
        when (skippedLevels > 1) $ do
          minBlockInterval <- cmiGetApproximateBlockInterval
          let waitTime = (skippedLevels - 1) * toNum @Second minBlockInterval
          threadDelay . sec $ waitTime % 1
        -- A chain's time resolution is never smaller than a second, so with (less
        -- than) a level to go we can wait for 1s in loop until we reach the target.
        let go :: ClientM ()
            go = do
              curLevel <- cmiGetLevel
              when (targetLevel > curLevel) $ threadDelay (sec 1) >> go
        go

    cmiRunCode
      :: forall cp st vd. (HasRPCRepr st, T.IsoValue (AsRPC st))
      => Sender -> RunCode cp st vd -> ClientM (AsRPC st)
    cmiRunCode (Sender sender) (RunCode rcContract rcStorage rcParameter rcAmount rcLevel rcNow rcBalance rcSource) =
      liftIO $ runMorleyClientM env do
        -- Pattern match on the contract constructor to reveal
        -- a proof of `NiceParameter cp` and `NiceStorage st`
        L.Contract{} <- pure rcContract
        T.fromVal <$> Client.runContract Client.RunContractParameters
          { rcpContract = L.toMichelsonContract $ rcContract
          , rcpStorage =
              case rcStorage of
                NotRPC v -> NotRPC $ toVal v
                IsRPC v -> IsRPC $ toVal v
          , rcpParameter =
              case rcParameter of
                NotRPC v -> NotRPC $ toVal v
                IsRPC v -> IsRPC $ toVal v
          , rcpAmount = rcAmount
          , rcpBalance = rcBalance
          , rcpSource = rcSource
          , rcpLevel = rcLevel
          , rcpNow = rcNow
          , rcpSender = Just sender
          }
          \\ L.niceParameterEvi @cp
          \\ L.niceStorageEvi @st

comment :: Text -> ClientM ()
comment msg = liftIO $ putTextLn msg >> hFlush stdout

getAlias :: MorleyClientEnv -> Address -> ClientM Alias
getAlias env = liftIO . runMorleyClientM env . Client.getAlias . AddressResolved

getLastBlockTimestamp :: MorleyClientEnv -> ClientM UTCTime
getLastBlockTimestamp env = liftIO $
  bhnhTimestamp . bcHeader <$> runMorleyClientM env (Client.getBlockConstants HeadId)

getLastBlockLevel :: MorleyClientEnv -> ClientM Natural
getLastBlockLevel env = do
  bc <- liftIO $ runMorleyClientM env (Client.getBlockConstants HeadId)
  pure . Unsafe.fromIntegral @Int64 @Natural . bhnhLevel $ bcHeader bc

runOperationBatch :: MorleyClientEnv -> Address -> [OperationInfo ClevelandInput] -> ClientM [OperationInfo Result]
runOperationBatch env sender ops = do
  istRef <- ask
  ClientState{csMoneybagAddress=Moneybag moneybag} <- readIORef istRef
  -- Note that tezos key reveal operation cost an additional fee
  -- so that's why we reveal keys in origination and transaction
  -- rather than doing it before scenario execution
  liftIO $ revealKeyUnlessRevealed env sender

  ops' <- forM ops \case
    OpOriginate uod ->
      OpOriginate <$> convertOriginateUntypedData uod
    OpTransfer td ->
      pure . OpTransfer $ convertTransferData td
    OpReveal key ->
      pure $ OpReveal RevealRPC.RevealData
        { rdPublicKey = key
        , rdMbFee = Nothing
        }

  let refill :: Word -> Client.MorleyClientM Word
      refill iter = do
        void $ dryRunOperations (AddressResolved sender) ops'
        pure iter
        `catch` \errs -> do
          when (iter > 3) $ throwM $ TooManyRefillIterations iter sender
          realBalance <- Client.getBalance sender
          let handleRunErrors errs'
                | Just (arg #balance -> balance, arg #required -> required)
                    <- findBalanceTooLow errs' = do
                    logInfo $ sender |+ " balance of " +| realBalance |+ " \n\
                              \is too low, need " +| required |+ ", but got " +| balance |+ ""
                    let reportedDifference = unsafeSubMutez required balance
                        -- required >= balance should always be true if we got 'BalanceTooLow'
                    if iter == 0
                    -- on first iteration, we dry-run the transaction as moneybag (if possible)
                    -- and esitmate the required balance that way;
                    then approximateRequired realBalance
                            `catch` \(_ :: SomeException) -> pure reportedDifference
                    -- on subsequent iterations (which run only if the first
                    -- wasn't enough), we rely on the reported `required` and `balance`,
                    -- NOTE: BalanceTooLow can be thrown either before fees are subtracted, or after.
                    -- In the former case, (required - balance == transfer_amount - real_balance)
                    -- In the latter case, (required - balance == transfer_amount - real_balance - fees)
                    -- Notice that fees are only included if real_balance >= transfer_amount.
                    -- Consequently, if transfer_amount > real_balance AND
                    -- transfer_amount + fees > real_balance + minimalMutez, the amount we transfer here
                    -- will be insufficient. TL;DR, it doesn't work for large transfer_amounts.
                    -- For batched transfers, this gets a bit more complicated, but the same principle
                    -- applies; unless total fees can exceed minimalMutez, or total transfer_amount
                    -- is large, it should work without looping.
                    else pure reportedDifference
                | findCantPayStorageFee errs' = do
                    logInfo $ sender |+ " balance of " +| realBalance |+ "\n\
                              \ is too low to pay storage fee"
                    -- since no required balance is reported, there is no choice
                    approximateRequired realBalance
                      -- if running as moneybag failed for some reason, just throw in some tez
                      -- and hope for the best
                      `catch` \(_ :: SomeException) -> pure minimalMutez
                | otherwise = throwM errs
          amount <- max minimalMutez . addSafetyMutez <$> if
            | Just (Client.UnexpectedRunErrors err) <- fromException errs -> handleRunErrors err
            | Just (RPC.RunCodeErrors err) <- fromException errs -> handleRunErrors err
            | otherwise -> throwM errs
          logInfo $ "Will transfer " +| amount |+ " from " +| moneybag |+ ""
          void $ Client.lTransfer moneybag sender amount U.DefEpName () Nothing
          refill (iter + 1) -- loop
      addSafetyMutez x = fromMaybe x $ addMutez x safetyMutez
      minimalMutez = 5e5
      safetyMutez = 100
      safetyStorage = 20
      approximateRequired balance = do
        -- dry-run as moneybag and estimate cost+burn+fees
        (appliedResults, fees) <- unzip <$> dryRunOperations (AddressResolved moneybag) ops'
        ProtocolParameters{..} <- Client.getProtocolParameters
        -- uses quite a bit of unsafe mutez arithmetic, but arguably
        -- if we end up running into overflow while computing the
        -- required balance, then we couldn't run these operations
        -- anyway.
        let totalFees = unsafeSumMutez fees
            unsafeSumMutez = foldr unsafeAddMutez zeroMutez
            zeroMutez = 0
            originationSz = Unsafe.fromIntegral @Int @Natural ppOriginationSize
            (opsSum, originationSize) = bimap unsafeSumMutez sum . unzip
              $ map opcostAndOriginationCount ops
            costPerByte = unTezosMutez ppCostPerByte
            opcostAndOriginationCount = \case
              OpOriginate uod -> (uodBalance uod, originationSz)
              OpTransfer td -> (tdAmount td, 0)
              OpReveal _ -> (zeroMutez, 0)
            storageDiff AppliedResult{..} = safetyStorage + Unsafe.fromIntegral @TezosInt64 @Natural arPaidStorageDiff
            storageBurnInBytes = originationSize + sum (map storageDiff appliedResults)
            storageBurnInMutez = unsafeMulMutez costPerByte storageBurnInBytes
            required = opsSum `unsafeAddMutez` totalFees `unsafeAddMutez` storageBurnInMutez
        logInfo $ "estimated amount needed is " +| required |+ ", but got " +| balance |+ "\n\
                  \Storage size: " +| storageBurnInBytes |+ "; Operations cost: " +| opsSum |+ "\n\
                  \Fees: " +| totalFees |+ "; Storage burn cost: " +| storageBurnInMutez |+ ""
        pure $ fromMaybe zeroMutez $ subMutez required balance

  refillable <- isAddressRefillable sender
  results <- liftIO $ runMorleyClientM env $ do
    when refillable $ do
      tookIters <- refill 0
      when (tookIters > 1) $ logWarning $
        "Refill of " +| sender |+ " took " +| tookIters |+ " iterations."
    snd <$> Client.runOperations (AddressResolved sender) ops'

  forM_ results $ \case
    OpTransfer () -> pass
    OpOriginate addr -> do
      alias <- getAlias env addr
      comment $ "Originated smart contract '" +| alias |+
        "' with address " <> pretty addr
    OpReveal () -> pass

  return results

dryRunOperations :: AddressOrAlias
                  -> [OperationInfo Client.ClientInput]
                  -> Client.MorleyClientM [(AppliedResult, Mutez)]
dryRunOperations s = \case
  [] -> return []
  (x:xs) -> toList . map (second unTezosMutez) <$> Client.dryRunOperationsNonEmpty s (x :| xs)

findBalanceTooLow :: [Client.RunError] -> Maybe ("balance" :! Mutez, "required" :! Mutez)
-- we really shouldn't get several errors of the same type here, so find only the first one
findBalanceTooLow
  (Client.BalanceTooLow balance required:_)
  = Just (balance, required)
findBalanceTooLow (_:xs) = findBalanceTooLow xs
findBalanceTooLow [] = Nothing

findCantPayStorageFee :: [Client.RunError] -> Bool
-- we really shouldn't get several errors of the same type here, so find only the first one
findCantPayStorageFee
  (Client.CantPayStorageFee:_)
  = True
findCantPayStorageFee (_:xs) = findCantPayStorageFee xs
findCantPayStorageFee [] = False

exceptionToTransferFailure :: RPC.ClientRpcError -> ClientM TransferFailure
exceptionToTransferFailure = \case
  RPC.ContractFailed addr expr -> return $ TransferFailure addr $ FailedWith (EOTVExpression expr) Nothing
  RPC.BadParameter addr _ -> return $ TransferFailure addr BadParameter
  RPC.EmptyTransaction addr -> return $ TransferFailure addr EmptyTransaction
  RPC.ShiftOverflow addr -> return $ TransferFailure addr ShiftOverflow
  RPC.GasExhaustion addr -> return $ TransferFailure addr GasExhaustion
  internalError -> throwM internalError

exceptionHandler :: ClientM a -> ClientM a
exceptionHandler action = try action >>= \case
  Left err -> exceptionToTransferFailure err >>= throwM
  Right res -> return res

runClientOrigination
  :: MorleyClientEnv
  -> Sender
  -> (  Bool
      -> Alias
      -> AddressOrAlias
      -> Mutez
      -> U.Contract
      -> U.Value
      -> Maybe Mutez
      -> Client.MorleyClientM (OperationHash, Address)
      )
  -> UntypedOriginateData
  -> ClientM (OperationHash, Address)
runClientOrigination env (Sender sender) mkScenario (UntypedOriginateData{..}) = do
  let originationScenario =
        mkScenario True uodName (AddressResolved sender)
          uodBalance uodContract uodStorage Nothing
  -- Note that tezos key reveal operation cost an additional fee
  -- so that's why we reveal keys in origination and transaction
  -- rather than doing it before scenario execution
  liftIO $ do
    revealKeyUnlessRevealed env sender
    runMorleyClientM env originationScenario

resolveSpecificOrDefaultAlias :: SpecificOrDefaultAlias -> ClientM Alias
resolveSpecificOrDefaultAlias (SpecificAlias alias) = pure alias
resolveSpecificOrDefaultAlias (DefaultAlias) = do
  stateRef <- ask
  ist@ClientState{csDefaultAliasCounter=DefaultAliasCounter counter} <- readIORef stateRef
  writeIORef stateRef ist{ csDefaultAliasCounter = DefaultAliasCounter $ counter + 1 }
  pure $ mkDefaultAlias counter

setAddressRefillable :: Address -> ClientM ()
setAddressRefillable addr = do
  stRef <- ask
  modifyIORef stRef $ \st@ClientState{..} ->
    st{csRefillableAddresses=Set.insert addr csRefillableAddresses}

isAddressRefillable :: Address -> ClientM Bool
isAddressRefillable addr = do
  stRef <- ask
  Set.member addr . csRefillableAddresses <$> readIORef stRef

----------------------------------------------------------------------------
-- Helpers
----------------------------------------------------------------------------

convertOriginateUntypedData
  :: (MonadThrow m)
  => UntypedOriginateData -> m Client.OriginationData
convertOriginateUntypedData UntypedOriginateData{..} = do
  SomeContractAndStorage contract storage <-
    throwLeft . pure $ typeCheckingWith def $
      typeCheckContractAndStorage uodContract uodStorage
  return Client.OriginationData
    { odReplaceExisting = True
    , odName = uodName
    , odBalance = uodBalance
    , odContract = contract
    , odStorage = storage
    , odMbFee = Nothing
    }

convertTransferData
  :: TransferData -> Client.TransactionData
convertTransferData TransferData{ tdParameter = param :: p, ..} =
  Client.TransactionData Client.TD
    { tdReceiver = toAddress tdTo
    , tdAmount = tdAmount
    , tdEpName = tdEntrypoint
    , tdParam = toVal param
    , tdMbFee = Nothing
    } \\ niceParameterEvi @p

-- | Runs 'Client.revealKeyUnlessRevealed' with given client environment.
revealKeyUnlessRevealed :: MorleyClientEnv -> Address -> IO ()
revealKeyUnlessRevealed env addr = runMorleyClientM env $
  -- We don't use password protected accounts in cleveland.
  Client.revealKeyUnlessRevealed addr Nothing

----------------------------------------------------------------------------
-- Validation
----------------------------------------------------------------------------

-- | Signals an assertion failure during the execution of an action.
newtype TestError
  = CustomTestError Text
  deriving stock Show

instance Exception TestError where
  displayException = pretty

instance Buildable TestError where
  build (CustomTestError msg) = build msg