Operation.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | Implementation of generic operations submission.
module Morley.Client.Action.Operation
  ( runOperations
  , runOperationsNonEmpty
  -- helpers
  , dryRunOperationsNonEmpty
  ) where

import Data.List (zipWith4)
import qualified Data.List.NonEmpty as NE
import Data.Singletons (Sing, SingI, sing)
import qualified Data.Text as T
import Fmt (blockListF', listF, pretty, (+|), (|+))

import Morley.Client.Action.Common
import Morley.Client.Logging
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.Micheline (StringEncode(..), TezosInt64, TezosMutez(..))
import Morley.Tezos.Address
import Morley.Tezos.Crypto
import Morley.Util.ByteString

logOperations
  :: forall (runMode :: RunMode) env m.
     ( WithClientLog env m
     , HasTezosClient m
     , SingI runMode -- We don't ask aliases with 'tezos-client' in 'DryRun' mode
     )
  => AddressOrAlias
  -> NonEmpty (Either TransactionData OriginationData)
  -> m ()
logOperations sender ops = do
  let runMode = sing @runMode

      opName =
        if | all isLeft ops -> "transactions"
           | all isRight ops -> "originations"
           | otherwise -> "operations"

      buildOp = \case
        (Left tx, mbAlias) ->
          buildTxDataWithAlias mbAlias tx
        (Right orig, _) ->
          odName orig |+ " (temporary alias)"

  sender' <- case sender of
    addr@AddressResolved{} -> case runMode of
      SRealRun -> AddressAlias <$> getAlias sender
      SDryRun  -> pure addr
    alias -> pure alias

  aliases <- case runMode of
    SRealRun ->
      forM ops $ \case
        Left (TransactionData tx) ->
          Just <$> (getAlias . AddressResolved $ tdReceiver tx)
        _ ->
          pure Nothing
    SDryRun -> pure $ ops $> Nothing

  logInfo $ T.strip $ -- strip trailing newline
    "Running " +| opName +| " by " +| sender' |+ ":\n" +|
    blockListF' "-" buildOp (ops `NE.zip` aliases)

-- | Perform sequence of operations.
--
-- Returns operation hash (or @Nothing@ in case empty list was provided) and result of
-- each operation (nothing for transactions and an address for originated contracts
runOperations
  :: forall m env.
     ( HasTezosRpc m
     , HasTezosClient m
     , WithClientLog env m
     )
  => AddressOrAlias
  -> [Either TransactionData OriginationData]
  -> m (Maybe OperationHash, [Either () Address])
runOperations sender operations = case operations of
  [] -> return (Nothing, [])
  op : ops -> do
    (opHash, res) <- runOperationsNonEmpty sender $ op :| ops
    return $ (Just opHash, toList res)

-- | Perform non-empty sequence of operations.
--
-- Returns operation hash and result of each operation
-- (nothing for transactions and an address for originated contracts).
runOperationsNonEmpty
  :: forall m env.
     ( HasTezosRpc m
     , HasTezosClient m
     , WithClientLog env m
     )
  => AddressOrAlias
  -> NonEmpty (Either TransactionData OriginationData)
  -> m (OperationHash, NonEmpty (Either () Address))
runOperationsNonEmpty sender operations =
  runOperationsNonEmptyHelper @'RealRun sender operations

-- | Flag that is used to determine @runOperationsNonEmptyHelper@ behaviour.
data RunMode = DryRun | RealRun

isRealRun :: forall (runMode :: RunMode). (SingI runMode) => Bool
isRealRun = case sing @runMode of
  SRealRun -> True
  SDryRun  -> False

-- | Type family which is used to determine the output type of the
-- @runOperationsNonEmptyHelper@.
type family RunResult (a :: RunMode) where
  RunResult 'DryRun = NonEmpty (AppliedResult, TezosMutez)
  RunResult 'RealRun = (OperationHash, NonEmpty (Either () Address))

data SingRunResult :: RunMode -> Type where
  SDryRun :: SingRunResult 'DryRun
  SRealRun :: SingRunResult 'RealRun

type instance Sing = SingRunResult

instance SingI 'DryRun where
  sing = SDryRun

instance SingI 'RealRun where
  sing = SRealRun

-- | Perform dry-run for sequence of operations.
--
-- Returned @AppliedResult@ contains information about estimated limits,
-- storage changes, etc. Additionally, estimated fees are returned.
dryRunOperationsNonEmpty
  :: forall m env.
     ( HasTezosRpc m
     , HasTezosClient m
     , WithClientLog env m
     )
  => AddressOrAlias
  -> NonEmpty (Either TransactionData OriginationData)
  -> m (NonEmpty (AppliedResult, TezosMutez))
dryRunOperationsNonEmpty sender operations =
  runOperationsNonEmptyHelper @'DryRun sender operations

-- | Perform non-empty sequence of operations and either dry-run
-- and return estimated limits and fees or perform operation injection.
-- Behaviour is defined via @RunMode@ flag argument.
runOperationsNonEmptyHelper
  :: forall (runMode :: RunMode) m env.
     ( HasTezosRpc m
     , HasTezosClient m
     , WithClientLog env m
     , SingI runMode
     )
  => AddressOrAlias
  -> NonEmpty (Either TransactionData OriginationData)
  -> m (RunResult runMode)
runOperationsNonEmptyHelper sender operations = do
  logOperations @runMode sender operations
  senderAddress <- resolveAddress sender
  prohibitContractSender senderAddress $ head operations
  mbPassword <- getKeyPassword senderAddress
  when (isRealRun @runMode) $
    revealKeyUnlessRevealed senderAddress mbPassword

  pp <- getProtocolParameters
  OperationConstants{..} <- preProcessOperation senderAddress

  let convertOps i = \case
        Left (TransactionData TD {..}) ->
          Left TransactionOperation
          { toDestination = tdReceiver
          , toCommonData = commonData
          , toAmount = TezosMutez tdAmount
          , toParameters = toParametersInternals tdEpName tdParam
          }
        Right OriginationData{..} ->
          Right OriginationOperation
          { ooCommonData = commonData
          , ooBalance = TezosMutez odBalance
          , ooScript = mkOriginationScript odContract odStorage
          }
        where
          commonData = mkCommonOperationData senderAddress (ocCounter + i) pp

  let opsToRun = NE.zipWith convertOps (1 :| [(2 :: TezosInt64)..]) operations
      mbFees = map (either (\(TransactionData TD {..}) -> tdMbFee) odMbFee) operations

  -- Perform run_operation with dumb signature in order
  -- to estimate gas cost, storage size and paid storage diff
  let runOp = RunOperation
        { roOperation = RunOperationInternal
          { roiBranch = ocLastBlockHash
          , roiContents = opsToRun
          , roiSignature = stubSignature
          }
        , roChainId = bcChainId ocBlockConstants
        }
  results <- getAppliedResults (Left runOp)

  let -- Learn how to forge given operations
      forgeOp :: NonEmpty (Either TransactionOperation OriginationOperation) -> m ByteString
      forgeOp ops =
        fmap unHexJSONByteString . forgeOperation $ ForgeOperation
          { foBranch = ocLastBlockHash
          , foContents = ops
          }

  let -- Attach a signature to forged operation + return the signature itself
      signForgedOp :: ByteString -> m (Signature, ByteString)
      signForgedOp op = do
        signature' <- signBytes sender mbPassword (addOperationPrefix op)
        return (signature', prepareOpForInjection op signature')

  -- Fill in fees
  let
    updateOp opToRun mbFee ar isFirst = do
      let storageLimit = computeStorageLimit [ar] pp + 20 -- similarly to tezos-client, we add 20 for safety
      let gasLimit = arConsumedGas ar + 100  -- adding extra for safety
          updateCommonDataForFee fee =
            updateCommonData gasLimit storageLimit (TezosMutez fee)

      (_fee, op, mReadySignedOp) <- convergingFee
        @(Either TransactionOperation OriginationOperation)
        @(Maybe (Signature, ByteString))  -- ready operation and its signature
        (\fee ->
          return $ bimap
            (toCommonDataL %~ updateCommonDataForFee fee)
            (ooCommonDataL %~ updateCommonDataForFee fee)
            opToRun
          )
        (\op -> do
          forgedOp <- forgeOp $ one op
          -- In the Tezos implementation the first transaction
          -- in the series pays for signature.
          -- Signature of hash should be constant in size,
          -- so we can pass any signature, not necessarily the final one
          (fullForgedOpLength, mExtra) <-
            if isFirst
              then do
                res@(_signature, signedOp) <- signForgedOp forgedOp
                return (length signedOp, Just res)
              else
                -- Forge output automatically includes additional 32-bytes header
                -- which should be ommited for all operations in batch except the first one.
                pure (length forgedOp - 32, Nothing)
          return
            ( maybe (computeFee ocFeeConstants fullForgedOpLength gasLimit) id mbFee
            , mExtra
            )
          )

      return (op, mReadySignedOp)

  let
    zipWith4NE
      :: (a -> b -> c -> d -> e) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d
      -> NonEmpty e
    zipWith4NE f (a :| as) (b :| bs) (c :| cs) (d :| ds) =
      (f a b c d) :| zipWith4 f as bs cs ds
  -- These two lists must have the same length here.
  -- @opsToRun@ is constructed directly from @params@.
  -- The length of @results@ is checked in @getAppliedResults@.
  (updOps, readySignedOps) <- fmap NE.unzip . sequenceA $
    zipWith4NE updateOp opsToRun mbFees results (True :| repeat False)

  -- Forge operation with given limits and get its hexadecimal representation
  (signature', signedOp) <- case readySignedOps of
    -- Save one forge + sign call pair in case of one operation
    Just readyOp :| [] -> pure readyOp
    -- In case of batch we have to reforge the full operation
    _ -> forgeOp updOps >>= signForgedOp

  -- Operation still can fail due to insufficient gas or storage limit, so it's required
  -- to preapply it before injecting
  let preApplyOp = PreApplyOperation
        { paoProtocol = bcProtocol ocBlockConstants
        , paoBranch = ocLastBlockHash
        , paoContents = updOps
        , paoSignature = signature'
        }
  ars2 <- getAppliedResults (Right preApplyOp)
  case sing @runMode of
    SDryRun -> do
      let fees = flip map updOps $ \case
            Left (TransactionOperation commonData _ _ _) -> codFee commonData
            Right (OriginationOperation commonData _ _) -> codFee commonData
      return $ NE.zip ars2 fees
    SRealRun -> do
      operationHash <- injectOperation (HexJSONByteString signedOp)
      waitForOperation operationHash
      let contractAddrs = arOriginatedContracts <$> ars2
      opsRes <- forM (NE.zip operations contractAddrs) $ \case
        (Left _, []) ->
          return $ Left ()
        (Left _, addrs) -> do
          logInfo . T.strip $
            "The following contracts were originated during transactions: " +|
            listF addrs |+ ""
          return $ Left ()
        (Right _, []) ->
          throwM RpcOriginatedNoContracts
        (Right OriginationData{..}, [addr]) -> do
          logDebug $ "Saving " +| addr |+ " for " +| odName |+ "\n"
          rememberContract odReplaceExisting addr (AnAliasHint odName)
          alias <- getAlias $ AddressResolved addr
          logInfo $ "Originated contract: " <> pretty alias
          return $ Right addr
        (Right _, addrs@(_ : _ : _)) ->
          throwM $ RpcOriginatedMoreContracts addrs
      forM_ ars2 logStatistics
      return (operationHash, opsRes)
  where
    logStatistics :: AppliedResult -> m ()
    logStatistics ar = do
      let showTezosInt64 = show . unStringEncode
      logInfo $ "Consumed gas: " <> showTezosInt64 (arConsumedGas ar)
      logInfo $ "Storage size: " <> showTezosInt64 (arStorageSize ar)
      logInfo $ "Paid storage size diff: " <> showTezosInt64 (arPaidStorageDiff ar)

    prohibitContractSender :: Address -> Either TransactionData OriginationData -> m ()
    prohibitContractSender addr op = case (addr, op) of
      (KeyAddress _, _) -> pass
      (ContractAddress _, Left _) -> throwM $ ContractSender addr "transfer"
      (ContractAddress _, Right _) -> throwM $ ContractSender addr "origination"