Client.hs

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

{-# OPTIONS_HADDOCK not-home #-}

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

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

  -- * Capability implementations
  , networkOpsImpl
  , networkMiscImpl

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

  -- * Environment
  , mkMorleyOnlyRpcEnvNetwork

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

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

import Control.Lens (_head, each, filtered)
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)
import Lorentz qualified as L
import Lorentz.Constraints.Scopes (NiceUnpackedValue)
import Morley.AsRPC (AsRPC, HasRPCRepr(..), TAsRPC, notesAsRPC, rpcSingIEvi)
import Morley.Client
  (AliasBehavior(..), MorleyClientEnv, OperationInfo(..), disableAlphanetWarning, runMorleyClientM)
import Morley.Client qualified as Client
import Morley.Client.Action (Result)
import Morley.Client.Action.Common (DelegationData(..), runErrorsToClientError)
import Morley.Client.Action.Reveal qualified as RevealRPC
import Morley.Client.App (failOnTimeout, retryOnceOnTimeout)
import Morley.Client.Full 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(..), IntOpEvent(..), OriginationScript(..),
  ProtocolParameters(ProtocolParameters, ppCostPerByte, ppMinimalBlockDelay, ppOriginationSize))
import Morley.Client.TezosClient.Impl qualified as TezosClient
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, toExpression)
import Morley.Michelson.Text (unMText)
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
import Morley.Tezos.Address.Alias
import Morley.Tezos.Core as Tezos
  (Mutez, Timestamp(..), addMutez, subMutez, timestampFromUTCTime, unsafeAddMutez, unsafeMulMutez,
  unsafeSubMutez)
import Morley.Tezos.Crypto
import Morley.Util.Constrained
import Morley.Util.Exception
import Morley.Util.Named
import Test.Cleveland.Internal.Abstract
import Test.Cleveland.Internal.Exceptions
import Test.Cleveland.Lorentz (toL1Address)
import Test.Cleveland.Util (ceilingUnit)

-- | Construct 'Client.MorleyOnlyRpcEnv' from 'NetworkEnv'.
mkMorleyOnlyRpcEnvNetwork
  :: NetworkEnv
  -> [SecretKey]  -- ^ Extra secrets that should be known
  -> Client.MorleyOnlyRpcEnv
mkMorleyOnlyRpcEnvNetwork NetworkEnv{..} extraSecrets =
  Client.MorleyOnlyRpcEnv
  { moreLogAction = Client.mkLogAction neVerbosity
  , 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 ImplicitAlias
  | TwoMoneybagKeys ImplicitAlias SecretKey ImplicitAddress
  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
  fromException = fromPossiblyAnnotatedException

data ClientState = ClientState
  { csDefaultAliasCounter :: DefaultAliasCounter
  , csRefillableAddresses :: Set ImplicitAddress
  , 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 ImplicitAddress
  deriving stock (Show)

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

instance Exception InternalNetworkScenarioError where
  displayException = pretty
  fromException = fromPossiblyAnnotatedException

runNetworkT :: NetworkEnv -> NetworkT ClientM a -> IO a
runNetworkT env scenario = do
  disableAlphanetWarning
  moneybagAddr <- setupMoneybagAddress env
  let caps = NetworkCaps
        { ncNetworkEnv = env
        , ncClevelandCaps = ClevelandCaps
            { ccSender = Sender $ unMoneybag moneybagAddr
            , ccMoneybag = moneybagAddr
            , ccMiscCap = networkMiscImpl 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 $
          (retryOnceOnTimeout ... TezosClient.getSecretKey)
          (AddressAlias neMoneybagAlias)
        void $ runMorleyClientM neMorleyClientEnv $
          failOnTimeout ... TezosClient.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 $
              failOnTimeout ... TezosClient.importKey False neMoneybagAlias ek
          pure sa
      | otherwise -> throwM $ TwoMoneybagKeys neMoneybagAlias ek sa
    (Just ek, Nothing) -> do
      runMorleyClientM neMorleyClientEnv $
        failOnTimeout ... TezosClient.importKey False neMoneybagAlias ek
      return $ mkKeyAddress (toPublic ek)

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

networkMiscImpl :: NetworkEnv -> ClevelandMiscImpl ClientM
networkMiscImpl env@NetworkEnv{..} =
  mapClevelandMiscImplExceptions (addCallStack . exceptionHandler neMorleyClientEnv) ClevelandMiscImpl
    { cmiRunIO = liftIO

    , cmiOriginateLargeUntyped = \(Sender sender) UntypedOriginateData{..} -> do
        let originationScenario =
              Client.originateLargeUntypedContract OverwriteDuplicateAlias uodName
                (AddressResolved sender) uodBalance uodContract uodStorage Nothing uodDelegate
        -- 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
        (_, res) <- liftIO $ do
          revealKeyUnlessRevealed neMorleyClientEnv sender
          runMorleyClientM neMorleyClientEnv originationScenario
        comment $ "Originated large smart contract " +| uodName |+ " with address " <> pretty res
        pure res

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

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

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

    , cmiGetBalance = foldConstrained getBalanceHelper
    , cmiGetChainId = liftIO $ runMorleyClientM neMorleyClientEnv Client.getChainId
    , cmiAttempt = try
    , cmiThrow = throwM
    , cmiMarkAddressRefillable = setAddressRefillable
    , cmiComment = comment
    , cmiUnderlyingImpl = pure $ Right env
    , cmiFailure = clientFailure
    , ..
    }
  where
    cmiGetBigMapValueMaybe :: (NicePackedValue k, NiceUnpackedValue v) => BigMapId k v -> k -> ClientM (Maybe v)
    cmiGetBigMapValueMaybe bigMapId k =
      liftIO . runMorleyClientM neMorleyClientEnv $ Client.readBigMapValueMaybe bigMapId k

    cmiGetAllBigMapValuesMaybe :: (NiceUnpackedValue v) => BigMapId k v -> ClientM (Maybe [v])
    cmiGetAllBigMapValuesMaybe bigMapId =
      liftIO . runMorleyClientM neMorleyClientEnv $ 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 -> clientFailure $ 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 -> clientFailure $ 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 :: ContractAddress -> ClientM SomeAnnotatedValue
    cmiGetSomeStorage addr = do
      OriginationScript {osCode, osStorage} <-
        liftIO . runMorleyClientM neMorleyClientEnv $ 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 ->
              clientFailure $ unlinesF
                [ "Failed to decode storage expression."
                , "Storage expression:"
                , indentF 2 $ build (J.encodeToTextBuilder osStorage)
                , "Decoding error:"
                , indentF 2 $ build err
                ]

    cmiResolveAddress :: Alias kind -> ClientM (KindedAddress kind)
    cmiResolveAddress =
      liftIO . runMorleyClientM neMorleyClientEnv . Client.resolveAddress . AddressAlias

    cmiGetPublicKey :: ImplicitAddress -> ClientM PublicKey
    cmiGetPublicKey = liftIO . runMorleyClientM neMorleyClientEnv .
      (retryOnceOnTimeout ... TezosClient.getPublicKey) . AddressResolved

    getBalanceHelper :: L1AddressKind kind => KindedAddress kind -> ClientM Mutez
    getBalanceHelper = liftIO . runMorleyClientM neMorleyClientEnv . Client.getBalance

    cmiGetDelegate :: L1Address -> ClientM (Maybe KeyHash)
    cmiGetDelegate =
      liftIO . runMorleyClientM neMorleyClientEnv . Client.getDelegate

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

    cmiGetLevel :: ClientM Natural
    cmiGetLevel = getLastBlockLevel neMorleyClientEnv

    cmiGetApproximateBlockInterval :: ClientM (Time Second)
    cmiGetApproximateBlockInterval = liftIO $ do
      pp <- runMorleyClientM neMorleyClientEnv $ 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 neMorleyClientEnv
      threadDelay deltaSec
      let
        go :: ClientM ()
        go = do
          now <- getLastBlockTimestamp neMorleyClientEnv
          if (now `diffUTCTime` t0) >= deltaSec'
            then pass
            else threadDelay (sec 1) >> go
      go

    cmiAdvanceToLevel :: (Natural -> Natural) -> ClientM ()
    cmiAdvanceToLevel targetLevelFn = do
      lastLevel <- getLastBlockLevel neMorleyClientEnv
      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 rcParameter rcStorage rcAmount rcLevel rcNow rcBalance rcSource) = do
      liftIO $ runMorleyClientM neMorleyClientEnv do
        -- Pattern match on the contract constructor to reveal
        -- a proof of `NiceStorage st`
        L.Contract{} <- pure rcContract
        T.fromVal <$> Client.runContract Client.RunContractParameters
          { rcpContract = L.toMichelsonContract $ rcContract
          , rcpParameter = rcParameter
          , rcpStorage = rcStorage
          , rcpAmount = rcAmount
          , rcpBalance = rcBalance
          , rcpSource = rcSource
          , rcpLevel = rcLevel
          , rcpNow = rcNow
          , rcpSender = Just sender
          }
      `catch` \case
        err@(RPC.RunCodeErrors errs)
          | Just clientErr <- runErrorsToClientError errs
          -> throwM =<< exceptionToTransferFailure neMorleyClientEnv clientErr
          | otherwise -> throwM err

clientFailure :: Builder -> ClientM a
clientFailure = throwM . CustomTestError . pretty

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

getAlias
  :: L1AddressKind kind
  => MorleyClientEnv
  -> KindedAddress kind
  -> ClientM (Alias kind)
getAlias env = liftIO . runMorleyClientM env . TezosClient.getAlias . AddressResolved

getAliasMaybe
  :: L1AddressKind kind
  => MorleyClientEnv
  -> KindedAddress kind
  -> ClientM (Maybe (Alias kind))
getAliasMaybe env = liftIO . runMorleyClientM env . Client.getAliasMaybe . 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
  -> ImplicitAddress
  -> [OperationInfo ClevelandInput]
  -> ClientM [OperationInfo ClevelandResult]
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
        }
    OpDelegation delegate ->
      pure $ OpDelegation DelegationData
        { ddDelegate = delegate
        , ddMbFee = 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)
              OpDelegation _ -> (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
    OpDelegation () -> pass

  mapM toClevelandResult results

toClevelandResult :: OperationInfo Result -> ClientM (OperationInfo ClevelandResult)
toClevelandResult = \case
  OpTransfer ops -> OpTransfer <$> mapM intOpEventToContractEvent ops
  OpOriginate ops -> pure $ OpOriginate ops
  OpReveal ops -> pure $ OpReveal ops
  OpDelegation ops -> pure $ OpDelegation ops

intOpEventToContractEvent :: IntOpEvent -> ClientM ContractEvent
intOpEventToContractEvent IntOpEvent{..} = do
  T.AsUType (ceType :: T.Notes t) <- either throwM (pure . toTy) $ fromExpression @U.T ioeType
  cePayload <- case ioePayload of
    Nothing -> pure Nothing
    Just payload -> case fromExpression @(T.Value t) . toExpression $ payload of
      Right value -> pure . Just $ SomeAnnotatedValue ceType value
      Left err ->
        clientFailure $ unlinesF
          [ "Failed to decode event payload expression."
          , "Payload expression:"
          , indentF 2 $ build (J.encodeToTextBuilder $ toExpression payload)
          , "Decoding error:"
          , indentF 2 $ build err
          ]
  pure $ ContractEvent
    { ceSource = ioeSource
    , ceTag = maybe "" unMText ioeTag
    , ..
    }
  where
    toTy :: U.T -> U.Ty
    toTy t = U.Ty t U.noAnn


dryRunOperations :: ImplicitAddressOrAlias
                  -> [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

resolveAddressAndAlias :: MorleyClientEnv -> KindedAddress kind -> ClientM AddressAndAlias
resolveAddressAndAlias env addr =
   case addr of
     ImplicitAddress{} -> AddressAndAlias addr <$> getAliasMaybe env addr
     ContractAddress{} -> AddressAndAlias addr <$> getAliasMaybe env addr
     TxRollupAddress{} -> pure (AddressAndAlias addr Nothing)

exceptionToTransferFailure :: MorleyClientEnv -> RPC.ClientRpcError -> ClientM TransferFailure
exceptionToTransferFailure env = \case
    RPC.ContractFailed addr expr -> mkTransferFailure addr $ FailedWith (EOTVExpression expr) Nothing
    RPC.BadParameter (MkAddress addr) _ -> mkTransferFailure addr BadParameter
    RPC.EmptyTransaction addr -> mkTransferFailure addr EmptyTransaction
    RPC.ShiftOverflow addr -> mkTransferFailure addr ShiftOverflow
    RPC.GasExhaustion addr -> mkTransferFailure addr GasExhaustion
    internalError -> throwM internalError
    where
      mkTransferFailure :: KindedAddress kind -> TransferFailureReason -> ClientM TransferFailure
      mkTransferFailure addr e = TransferFailure <$> resolveAddressAndAlias env addr <*> pure e

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

resolveSpecificOrDefaultAlias :: SpecificOrDefaultAlias -> ClientM ImplicitAlias
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 :: ImplicitAddress -> ClientM ()
setAddressRefillable addr = do
  stRef <- ask
  modifyIORef stRef $ \st@ClientState{..} ->
    st{csRefillableAddresses=Set.insert addr csRefillableAddresses}

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

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

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

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

-- | Runs 'Client.revealKeyUnlessRevealed' with given client environment.
revealKeyUnlessRevealed :: MorleyClientEnv -> ImplicitAddress -> 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
  fromException = fromPossiblyAnnotatedException

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