Common.hs

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

-- | Module with functions that used in both transaction sending and contract
-- origination.
module Morley.Client.Action.Common
  ( OperationConstants(..)
  , TD (..)
  , TransactionData(..)
  , OriginationData(..)
  , TransferTicketData(..)
  , RevealData(..)
  , DelegationData(..)
  , ClientInput
  , addOperationPrefix
  , buildTxDataWithAlias
  , buildTxTicketDataWithAlias
  , getAppliedResults
  , computeFee
  , computeStorageLimit
  , convergingFee
  , preProcessOperation
  , stubSignature
  , prepareOpForInjection
  , updateCommonData
  , toParametersInternals
  , mkOriginationScript
  , handleOperationResult
  , runErrorsToClientError
  ) where

import Control.Lens (Prism')
import Data.ByteString (cons)
import Data.Default (def)
import Fmt (Buildable(..), Doc, (+|), (|+))

import Morley.Client.RPC.Class
import Morley.Client.RPC.Error
import Morley.Client.RPC.Getters
import Morley.Client.RPC.Types
import Morley.Client.TezosClient
import Morley.Client.Types
import Morley.Client.Util
import Morley.Micheline (TezosInt64, TezosMutez(..), toExpression)
import Morley.Micheline.Expression (expressionString)
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Typed.Scope
import Morley.Michelson.Untyped.Entrypoints
import Morley.Tezos.Address
import Morley.Tezos.Address.Alias
import Morley.Tezos.Core
import Morley.Tezos.Crypto

-- | Datatype that contains various values required for
-- chain operations.
data OperationConstants = OperationConstants
  { ocLastBlockHash :: BlockHash
  -- ^ Block in which operations is going to be injected
  , ocBlockConstants :: BlockConstants
  -- ^ Information about block: chain_id and protocol
  , ocFeeConstants :: FeeConstants
  -- ^ Information about fees
  , ocCounter :: TezosInt64
  -- ^ Sender counter
  }

-- | Helper for 'TransactionData' and t'Morley.Client.Action.Transaction.LTransactionData'.
data TD (t :: Type) = TD
  { tdReceiver :: L1Address
  , tdAmount :: Mutez
  , tdEpName :: EpName
  , tdParam :: t
  , tdMbFee :: Maybe Mutez
  }

-- | Data for a single transaction in a batch.
data TransactionData where
  TransactionData ::
    forall (t :: T.T). ParameterScope t =>
    TD (T.Value t) -> TransactionData

instance Buildable TransactionData where
  build = buildTxDataWithAlias Nothing

-- | Builds 'TransactionData' with additional info about receiver's alias, if present.
buildTxDataWithAlias :: Maybe SomeAlias -> TransactionData -> Doc
buildTxDataWithAlias mbAlias (TransactionData TD{..}) =
  "To: " +| tdReceiver |+ buildMbAlias mbAlias |+ ". EP: " +| tdEpName |+
  ". Parameter: " +| tdParam |+ ". Amount: " +| tdAmount |+ ""
  where
    buildMbAlias :: Maybe SomeAlias -> Doc
    buildMbAlias = maybe "" $ \a -> " (" +| a |+ ")"

-- | Builds 'TransactionData' with additional info about receiver's alias, if present.
buildTxTicketDataWithAlias :: Maybe SomeAlias -> TransferTicketData -> Doc
buildTxTicketDataWithAlias mbAlias
  (TransferTicketData contents ticketer amount dest ep _mbFee) =
  "To: " +| dest |+ buildMbAlias mbAlias |+ ". EP: " +| ep
  |+ ". Ticketer: " +| ticketer
  |+ " contents: " +| contents
  |+ " amount: " +| amount
  |+ ""
  where
    buildMbAlias :: Maybe SomeAlias -> Doc
    buildMbAlias = maybe "" $ \a -> " (" +| a |+ ")"

-- | Data for a single origination in a batch
data OriginationData =
  forall cp st. (ParameterScope cp, StorageScope st) => OriginationData
  { odAliasBehavior :: AliasBehavior
  , odName :: ContractAlias
  , odBalance :: Mutez
  , odContract :: T.Contract cp st
  , odStorage :: T.Value st
  , odDelegate :: Maybe KeyHash
  , odMbFee :: Maybe Mutez
  }

data DelegationData = DelegationData
  { ddDelegate :: Maybe KeyHash
  , ddMbFee :: Maybe Mutez
  }

data RevealData = RevealData
  { rdPublicKey :: PublicKey
    -- TODO [#516]: extract mbFee out of 'TransactionData', 'OriginationData', 'DelegationData'
    -- and here, try to delete 'RevealData' datatype and pass 'PublicKey' instead
  , rdMbFee :: Maybe Mutez
  }

data TransferTicketData = forall t. (ParameterScope t, Comparable t) => TransferTicketData
  { ttdTicketContents :: T.Value t
  , ttdTicketTicketer :: Address
  , ttdTicketAmount :: Natural
  , ttdDestination :: Address
  , ttdEntrypoint :: EpName
  , ttdMbFee :: Maybe Mutez
  }

-- | Standard operation input in morley-client interface.
data ClientInput
instance OperationInfoDescriptor ClientInput where
  type TransferInfo ClientInput = TransactionData
  type TransferTicketInfo ClientInput = TransferTicketData
  type OriginationInfo ClientInput = OriginationData
  type RevealInfo ClientInput = RevealData
  type DelegationInfo ClientInput = DelegationData

toParametersInternals
  :: ParameterScope t
  => EpName
  -> T.Value t
  -> ParametersInternal
toParametersInternals epName epParam = ParametersInternal
  { piEntrypoint = epNameToTezosEp epName
  , piValue = toExpression epParam
  }

mkOriginationScript
  :: T.Contract cp st -> T.Value st -> OriginationScript
mkOriginationScript contract@T.Contract{} initialStorage = OriginationScript
  { osCode = toExpression contract
  , osStorage = toExpression initialStorage
  }

-- | Preprocess chain operation in order to get required constants.
preProcessOperation
  :: (HasTezosRpc m) => ImplicitAddress -> m OperationConstants
preProcessOperation sourceAddr = do
  -- NOTE: The block hash returned by this function will be used in the "branch"
  -- field of other operations (e.g. `run_operation`, `forge` and `preapply`).
  --
  -- As of the introduction of the `ithaca` protocol and
  -- the Tenderbake consensus algorithm, it is no longer safe to use the `head` block
  -- as the branch of those operations, because that block "is not necessarily final".
  --
  -- Instead, we should use the `head~2` block.
  --
  -- See:
  --   * https://web.archive.org/web/20220305165609/https://tezos.gitlab.io/protocols/tenderbake.html
  --   * https://web.archive.org/web/20220305165704/https://tezos.gitlab.io/protocols/012_ithaca.html
  ocLastBlockHash <- getBlockHash FinalHeadId
  ocBlockConstants <- getBlockConstants (BlockHashId ocLastBlockHash)
  let ocFeeConstants = def
  ocCounter <- getImplicitContractCounter sourceAddr
  pure OperationConstants{..}

-- | Perform runOperation or preApplyOperations and combine the results.
--
-- If an error occurs, this function tries to turn errors returned by RPC
-- into 'ClientRpcError'. If it can't do the conversion, 'UnexpectedErrors'
-- will be thrown.
getAppliedResults
  :: (HasTezosRpc m)
  => Either RunOperation PreApplyOperation -> m (NonEmpty AppliedResult, [OperationResp WithSource])
getAppliedResults op = do
  (runResult, expectedContentsSize) <- case op of
    Left runOp ->
      (, length $ roiContents $ roOperation runOp) <$> runOperation runOp
    Right preApplyOp -> do
      results <- preApplyOperations [preApplyOp]
      -- There must be exactly one result because we pass a list
      -- consisting of 1 item.
      case results of
        [result] -> pure (result, length $ paoContents preApplyOp)
        _ -> throwM $ RpcUnexpectedSize 1 (length results)

  handleOperationResult runResult expectedContentsSize

-- | Handle a result of an operation: throw errors if there was an error,
-- return a nonempty list of applied results if there weren't.
handleOperationResult
  :: MonadThrow m
  => RunOperationResult -> Int -> m (NonEmpty AppliedResult, [OperationResp WithSource])
handleOperationResult RunOperationResult{..} expectedContentsSize = do
  when (length rrOperationContents /= expectedContentsSize) $
    throwM $ RpcUnexpectedSize expectedContentsSize (length rrOperationContents)

  let (appliedResults, runErrors) =
        sconcat $ first pure . collectResults <$> rrOperationContents
      ioDatas = concatMap (map ioData . rmInternalOperationResults . ocMetadata)
        $ toList rrOperationContents
      ops = sconcat $ rrOperationContents <&> \op ->
        ocOperation op :| (fmap ioData $ rmInternalOperationResults $ ocMetadata op)

  whenJust runErrors $ handleErrors ops

  pure (appliedResults, ioDatas)

  where
    collectResults :: OperationContent -> (AppliedResult, Maybe [RunError])
    collectResults (OperationContent _ (RunMetadata res internalOps)) =
      res : map ioResult internalOps
      & flip foldr (mempty, Nothing) \case
        OperationApplied result -> first (result <>)
        OperationFailed errors -> second (Just errors <>)

    handleErrors :: MonadThrow m => NonEmpty (OperationResp WithSource) -> [RunError] -> m a
    handleErrors iops errs
      | Just err <- runErrorsToClientError errs = throwM $ ClientRpcErrorWithStack iops err
      | otherwise = throwM $ ClientRpcErrorWithStack iops $ UnexpectedRunErrors errs


-- | When an error happens, we will get a list of 'RunError' in response. This
-- list often contains more than one item. We tested which errors are returned
-- in certain scenarios and added handling of such scenarios here. We don't rely
-- on any specific order of errors and on the number of errors. For example, in
-- case of bad parameter this number can be different.
runErrorsToClientError :: [RunError] -> Maybe ClientRpcError
runErrorsToClientError errs
  | Just address <- findError _RuntimeError
  , Just expr <- findError _ScriptRejected
  = pure $ ContractFailed address expr
  -- This case should be removed once 006 is finally deprecated
  | Just address <- findError _BadContractParameter
  , Just (_, expr) <- findError _InvalidSyntacticConstantError
  = pure $ BadParameter address expr
  | Just address <- findError _BadContractParameter
  , Just (_, expr) <- findError _InvalidConstant
  = pure $ BadParameter address expr
  | Just address <- findError _BadContractParameter
  , Just notation <- findError _InvalidContractNotation
  = pure $ BadParameter address (expressionString notation)
  | Just address <- findError _REEmptyTransaction
  = pure $ EmptyTransaction address
  | Just address <- findError _RuntimeError
  , Just _ <- findError _ScriptOverflow
  = pure $ ShiftOverflow address
  | Just address <- findError _RuntimeError
  , Just _ <- findError _GasExhaustedOperation
  = pure $ GasExhaustion address
  | Just address <- findError _PreviouslyRevealedKey
  = pure $ KeyAlreadyRevealed address
  | Just address <- findError _UnregisteredDelegate
  = pure $ DelegateNotRegistered address
  | otherwise = Nothing
  where
    findError :: Prism' RunError a -> Maybe a
    findError prism = fmap head . nonEmpty . mapMaybe (preview prism) $ errs

-- | Compute fee for operation.
computeFee :: FeeConstants -> Int -> TezosInt64 -> Mutez
computeFee FeeConstants{..} opSize gasLimit =
  -- Here and further we mostly follow the Tezos implementation:
  -- https://gitlab.com/tezos/tezos/-/blob/14d6dafd23eeafe30d931a41d43c99b1ebed5373/src/proto_alpha/lib_client/injection.ml#L584

  unsafe . mkMutez @Word64 . ceiling . sum $
    [ toRational $ unMutez fcBase
    , toRational fcMutezPerOpByte * toRational opSize
    , toRational fcMutezPerGas * toRational gasLimit
    ]

-- | @convergingFee mkOperation countFee@ tries to find the most minimal fee
-- @F@ and the respective operation @Op@ so that @mkOperation F = Op@ and
-- @countFee Op <= F@.
convergingFee
  :: forall op extra m. Monad m
  => (Mutez -> m op)
  -> (op -> m (Mutez, extra))
  -> m (Mutez, op, extra)
convergingFee mkOperation countFee = iterateFee 5 assessedMinimalFee
  where
    assessedMinimalFee = zeroMutez
    -- ↑ In real life we can encounter small fees like ~300 mutez
    -- (for small transfers to implicit addresses), but even if we set this
    -- as a starting fee, we won't win any number of iteration steps.
    -- So setting just zero.

    {- We have to use iterative algorithm because fees are included into
       operation, and higher fees increase operation size and thus fee may
       grow again. Fortunatelly, fees strictly grow with operation size and
       operation size strictly grows with fees, so the implementation is simple.
    -}
    iterateFee :: Word -> Mutez -> m (Mutez, op, extra)
    iterateFee 0 _ = error "Failed to converge at some fee"
    iterateFee countdown curFee = do
      op <- mkOperation curFee
      (requiredFee, extra) <- countFee op
      if requiredFee <= curFee
        then pure (curFee, op, extra)
        else iterateFee (countdown - 1) requiredFee

-- | Compute storage limit based on the results of the operations application
-- and given @ProtocolParameters@.
computeStorageLimit :: [AppliedResult] -> ProtocolParameters -> TezosInt64
computeStorageLimit appliedResults pp = sum $ map (\ar -> sum
  [ arPaidStorageDiff ar
  , (arAllocatedDestinationContracts ar) * fromIntegral (ppOriginationSize pp)
  , length (arOriginatedContracts ar) * fromIntegral (ppOriginationSize pp)
  ]) appliedResults

-- | Update common operation data based on preliminary run which estimates storage and
-- gas limits and fee.
--
-- Reference implementation adds 100 gas and 20 bytes to the limits for safety.
updateCommonData
  :: TezosInt64 -> TezosInt64 -> TezosMutez
  -> CommonOperationData -> CommonOperationData
updateCommonData gasLimit storageLimit fee commonData =
  commonData
  { codGasLimit = gasLimit
  , codStorageLimit = storageLimit
  , codFee = fee
  }

stubSignature :: Signature
stubSignature = unsafe $ parseSignature
  "edsigtXomBKi5CTRf5cjATJWSyaRvhfYNHqSUGrn4SdbYRcGwQrUGjzEfQDTuqHhuA8b2d8NarZjz8TRf65WkpQmo423BtomS8Q"

addOperationPrefix :: ByteString -> ByteString
addOperationPrefix = cons 0x03

prepareOpForInjection :: ByteString -> Signature -> ByteString
prepareOpForInjection operationHex signature' =
  operationHex <> prefix <> signatureToBytes signature'
  where
    prefix
      -- Apparently, because BLS signature is longer than other ones, this hacky
      -- workaround is employed. This may or may not come up elsewhere.
      -- see https://gitlab.com/tezos/tezos/-/merge_requests/5444
      | SignatureBLS{} <- signature' = "\xff\x03"
      | otherwise = mempty