{-# LANGUAGE LambdaCase #-}

module Cardano.Rpc.Server.Internal.UtxoRpc.Type.TxEval
  ( mkProtoTxEval
  , mkProtoRedeemer
  , scriptExecutionErrorToEvalReport
  , scriptWitnessIndexToRedeemerPurpose
  )
where

import Cardano.Api.Era
import Cardano.Api.Ledger qualified as L
import Cardano.Api.Plutus
import Cardano.Api.Tx
import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as U5c
import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc
import Cardano.Rpc.Server.Internal.Orphans ()
import Cardano.Rpc.Server.Internal.UtxoRpc.Type.PlutusData

import RIO hiding (toList)

import Data.Map.Strict qualified as M
import Data.ProtoLens (defMessage)
import GHC.IsList
import Network.GRPC.Spec

-- | Assemble a proto 'TxEval' response from the computed fee, per-redeemer
-- evaluation results, and redeemer Plutus data from the transaction witness set.
mkProtoTxEval
  :: L.Coin
  -- ^ Computed minimum fee
  -> Map ScriptWitnessIndex (Either ScriptExecutionError ([Text], ExecutionUnits))
  -- ^ Per-redeemer evaluation results: script traces and execution units on
  -- success, or a script execution error on failure
  -> Map ScriptWitnessIndex (ScriptData, ByteString)
  -- ^ Redeemer Plutus data extracted from the transaction witness set, keyed
  -- by script witness index, with decoded payload and CBOR bytes.
  -> Proto UtxoRpc.TxEval
mkProtoTxEval :: Coin
-> Map
     ScriptWitnessIndex
     (Either ScriptExecutionError ([Text], ExecutionUnits))
-> Map ScriptWitnessIndex (ScriptData, ByteString)
-> Proto TxEval
mkProtoTxEval Coin
fee Map
  ScriptWitnessIndex
  (Either ScriptExecutionError ([Text], ExecutionUnits))
evalMap Map ScriptWitnessIndex (ScriptData, ByteString)
redeemerLookup = do
  let (Map ScriptWitnessIndex ScriptExecutionError
failures, Map ScriptWitnessIndex ([Text], ExecutionUnits)
successes) = (Either ScriptExecutionError ([Text], ExecutionUnits)
 -> Either ScriptExecutionError ([Text], ExecutionUnits))
-> Map
     ScriptWitnessIndex
     (Either ScriptExecutionError ([Text], ExecutionUnits))
-> (Map ScriptWitnessIndex ScriptExecutionError,
    Map ScriptWitnessIndex ([Text], ExecutionUnits))
forall a b c k. (a -> Either b c) -> Map k a -> (Map k b, Map k c)
M.mapEither Either ScriptExecutionError ([Text], ExecutionUnits)
-> Either ScriptExecutionError ([Text], ExecutionUnits)
forall a. a -> a
id Map
  ScriptWitnessIndex
  (Either ScriptExecutionError ([Text], ExecutionUnits))
evalMap
      totalSteps :: Natural
totalSteps = [Natural] -> Natural
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ExecutionUnits -> Natural
executionSteps ExecutionUnits
units | ([Text]
_, ExecutionUnits
units) <- Map ScriptWitnessIndex ([Text], ExecutionUnits)
-> [([Text], ExecutionUnits)]
forall k a. Map k a -> [a]
M.elems Map ScriptWitnessIndex ([Text], ExecutionUnits)
successes]
      totalMemory :: Natural
totalMemory = [Natural] -> Natural
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ExecutionUnits -> Natural
executionMemory ExecutionUnits
units | ([Text]
_, ExecutionUnits
units) <- Map ScriptWitnessIndex ([Text], ExecutionUnits)
-> [([Text], ExecutionUnits)]
forall k a. Map k a -> [a]
M.elems Map ScriptWitnessIndex ([Text], ExecutionUnits)
successes]
      protoExecutionUnits :: Proto ExUnits
protoExecutionUnits =
        Proto ExUnits
forall msg. Message msg => msg
defMessage
          Proto ExUnits -> (Proto ExUnits -> Proto ExUnits) -> Proto ExUnits
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto ExUnits) Word64
forall (f :: * -> *) s a.
(Functor f, HasField s "steps" a) =>
LensLike' f s a
U5c.steps LensLike' Identity (Proto ExUnits) Word64
-> Word64 -> Proto ExUnits -> Proto ExUnits
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
totalSteps
          Proto ExUnits -> (Proto ExUnits -> Proto ExUnits) -> Proto ExUnits
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto ExUnits) Word64
forall (f :: * -> *) s a.
(Functor f, HasField s "memory" a) =>
LensLike' f s a
U5c.memory LensLike' Identity (Proto ExUnits) Word64
-> Word64 -> Proto ExUnits -> Proto ExUnits
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
totalMemory
      protoRedeemers :: [Proto Redeemer]
protoRedeemers =
        [ ScriptWitnessIndex
-> ExecutionUnits
-> Maybe (ScriptData, ByteString)
-> Proto Redeemer
mkProtoRedeemer ScriptWitnessIndex
witness ExecutionUnits
units (Maybe (ScriptData, ByteString) -> Proto Redeemer)
-> Maybe (ScriptData, ByteString) -> Proto Redeemer
forall a b. (a -> b) -> a -> b
$ ScriptWitnessIndex
-> Map ScriptWitnessIndex (ScriptData, ByteString)
-> Maybe (ScriptData, ByteString)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ScriptWitnessIndex
witness Map ScriptWitnessIndex (ScriptData, ByteString)
redeemerLookup
        | (ScriptWitnessIndex
witness, ([Text]
_, ExecutionUnits
units)) <- Map ScriptWitnessIndex ([Text], ExecutionUnits)
-> [Item (Map ScriptWitnessIndex ([Text], ExecutionUnits))]
forall l. IsList l => l -> [Item l]
toList Map ScriptWitnessIndex ([Text], ExecutionUnits)
successes
        ]
      protoErrors :: [Proto EvalReport]
protoErrors =
        [ ScriptWitnessIndex -> ScriptExecutionError -> Proto EvalReport
scriptExecutionErrorToEvalReport ScriptWitnessIndex
witness ScriptExecutionError
err
        | (ScriptWitnessIndex
witness, ScriptExecutionError
err) <- Map ScriptWitnessIndex ScriptExecutionError
-> [Item (Map ScriptWitnessIndex ScriptExecutionError)]
forall l. IsList l => l -> [Item l]
toList Map ScriptWitnessIndex ScriptExecutionError
failures
        ]
      protoTraces :: [Proto EvalReport]
protoTraces =
        [ do
            let (Proto RedeemerPurpose
purpose, Word32
idx) = ScriptWitnessIndex -> (Proto RedeemerPurpose, Word32)
scriptWitnessIndexToRedeemerPurpose ScriptWitnessIndex
witness
            Proto EvalReport
forall msg. Message msg => msg
defMessage
              Proto EvalReport
-> (Proto EvalReport -> Proto EvalReport) -> Proto EvalReport
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto EvalReport) Text
forall (f :: * -> *) s a.
(Functor f, HasField s "msg" a) =>
LensLike' f s a
U5c.msg LensLike' Identity (Proto EvalReport) Text
-> Text -> Proto EvalReport -> Proto EvalReport
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
traceLine
              Proto EvalReport
-> (Proto EvalReport -> Proto EvalReport) -> Proto EvalReport
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto EvalReport) (Proto RedeemerPurpose)
forall (f :: * -> *) s a.
(Functor f, HasField s "purpose" a) =>
LensLike' f s a
U5c.purpose LensLike' Identity (Proto EvalReport) (Proto RedeemerPurpose)
-> Proto RedeemerPurpose -> Proto EvalReport -> Proto EvalReport
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Proto RedeemerPurpose
purpose
              Proto EvalReport
-> (Proto EvalReport -> Proto EvalReport) -> Proto EvalReport
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto EvalReport) Word32
forall (f :: * -> *) s a.
(Functor f, HasField s "index" a) =>
LensLike' f s a
U5c.index LensLike' Identity (Proto EvalReport) Word32
-> Word32 -> Proto EvalReport -> Proto EvalReport
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32
idx
        | (ScriptWitnessIndex
witness, ([Text]
traces, ExecutionUnits
_)) <- Map ScriptWitnessIndex ([Text], ExecutionUnits)
-> [Item (Map ScriptWitnessIndex ([Text], ExecutionUnits))]
forall l. IsList l => l -> [Item l]
toList Map ScriptWitnessIndex ([Text], ExecutionUnits)
successes
        , Text
traceLine <- [Text]
traces
        ]
  Proto TxEval
forall msg. Message msg => msg
defMessage
    Proto TxEval -> (Proto TxEval -> Proto TxEval) -> Proto TxEval
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto TxEval) (Proto BigInt)
forall (f :: * -> *) s a.
(Functor f, HasField s "fee" a) =>
LensLike' f s a
U5c.fee LensLike' Identity (Proto TxEval) (Proto BigInt)
-> Proto BigInt -> Proto TxEval -> Proto TxEval
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> Proto BigInt
forall t s. Inject t s => t -> s
inject Coin
fee
    Proto TxEval -> (Proto TxEval -> Proto TxEval) -> Proto TxEval
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto TxEval) (Proto ExUnits)
forall (f :: * -> *) s a.
(Functor f, HasField s "exUnits" a) =>
LensLike' f s a
U5c.exUnits LensLike' Identity (Proto TxEval) (Proto ExUnits)
-> Proto ExUnits -> Proto TxEval -> Proto TxEval
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Proto ExUnits
protoExecutionUnits
    Proto TxEval -> (Proto TxEval -> Proto TxEval) -> Proto TxEval
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto TxEval) [Proto Redeemer]
forall (f :: * -> *) s a.
(Functor f, HasField s "redeemers" a) =>
LensLike' f s a
U5c.redeemers LensLike' Identity (Proto TxEval) [Proto Redeemer]
-> [Proto Redeemer] -> Proto TxEval -> Proto TxEval
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Proto Redeemer]
protoRedeemers
    Proto TxEval -> (Proto TxEval -> Proto TxEval) -> Proto TxEval
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto TxEval) [Proto EvalReport]
forall (f :: * -> *) s a.
(Functor f, HasField s "errors" a) =>
LensLike' f s a
U5c.errors LensLike' Identity (Proto TxEval) [Proto EvalReport]
-> [Proto EvalReport] -> Proto TxEval -> Proto TxEval
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Proto EvalReport]
protoErrors
    Proto TxEval -> (Proto TxEval -> Proto TxEval) -> Proto TxEval
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto TxEval) [Proto EvalReport]
forall (f :: * -> *) s a.
(Functor f, HasField s "traces" a) =>
LensLike' f s a
U5c.traces LensLike' Identity (Proto TxEval) [Proto EvalReport]
-> [Proto EvalReport] -> Proto TxEval -> Proto TxEval
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Proto EvalReport]
protoTraces

-- | Assemble a proto 'Redeemer' from evaluation results and transaction
-- witness data.
mkProtoRedeemer
  :: ScriptWitnessIndex
  -- ^ Redeemer purpose and index
  -> ExecutionUnits
  -- ^ Execution units consumed
  -> Maybe (ScriptData, ByteString)
  -- ^ Plutus data payload and its CBOR bytes
  -> Proto UtxoRpc.Redeemer
mkProtoRedeemer :: ScriptWitnessIndex
-> ExecutionUnits
-> Maybe (ScriptData, ByteString)
-> Proto Redeemer
mkProtoRedeemer ScriptWitnessIndex
swi ExecutionUnits
exUnits Maybe (ScriptData, ByteString)
redeemerDatum = do
  let (Proto RedeemerPurpose
purpose, Word32
idx) = ScriptWitnessIndex -> (Proto RedeemerPurpose, Word32)
scriptWitnessIndexToRedeemerPurpose ScriptWitnessIndex
swi
      protoExUnits :: Proto ExUnits
protoExUnits =
        Proto ExUnits
forall msg. Message msg => msg
defMessage
          Proto ExUnits -> (Proto ExUnits -> Proto ExUnits) -> Proto ExUnits
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto ExUnits) Word64
forall (f :: * -> *) s a.
(Functor f, HasField s "steps" a) =>
LensLike' f s a
U5c.steps LensLike' Identity (Proto ExUnits) Word64
-> Word64 -> Proto ExUnits -> Proto ExUnits
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ExecutionUnits -> Natural
executionSteps ExecutionUnits
exUnits)
          Proto ExUnits -> (Proto ExUnits -> Proto ExUnits) -> Proto ExUnits
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto ExUnits) Word64
forall (f :: * -> *) s a.
(Functor f, HasField s "memory" a) =>
LensLike' f s a
U5c.memory LensLike' Identity (Proto ExUnits) Word64
-> Word64 -> Proto ExUnits -> Proto ExUnits
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ExecutionUnits -> Natural
executionMemory ExecutionUnits
exUnits)
  Proto Redeemer
forall msg. Message msg => msg
defMessage
    Proto Redeemer
-> (Proto Redeemer -> Proto Redeemer) -> Proto Redeemer
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto Redeemer) (Proto RedeemerPurpose)
forall (f :: * -> *) s a.
(Functor f, HasField s "purpose" a) =>
LensLike' f s a
U5c.purpose LensLike' Identity (Proto Redeemer) (Proto RedeemerPurpose)
-> Proto RedeemerPurpose -> Proto Redeemer -> Proto Redeemer
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Proto RedeemerPurpose
purpose
    Proto Redeemer
-> (Proto Redeemer -> Proto Redeemer) -> Proto Redeemer
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto Redeemer) Word32
forall (f :: * -> *) s a.
(Functor f, HasField s "index" a) =>
LensLike' f s a
U5c.index LensLike' Identity (Proto Redeemer) Word32
-> Word32 -> Proto Redeemer -> Proto Redeemer
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32
idx
    Proto Redeemer
-> (Proto Redeemer -> Proto Redeemer) -> Proto Redeemer
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto Redeemer) (Proto ExUnits)
forall (f :: * -> *) s a.
(Functor f, HasField s "exUnits" a) =>
LensLike' f s a
U5c.exUnits LensLike' Identity (Proto Redeemer) (Proto ExUnits)
-> Proto ExUnits -> Proto Redeemer -> Proto Redeemer
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Proto ExUnits
protoExUnits
    Proto Redeemer
-> (Proto Redeemer -> Proto Redeemer) -> Proto Redeemer
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto Redeemer) (Maybe (Proto PlutusData))
forall (f :: * -> *) s a.
(Functor f, HasField s "maybe'payload" a) =>
LensLike' f s a
U5c.maybe'payload LensLike' Identity (Proto Redeemer) (Maybe (Proto PlutusData))
-> Maybe (Proto PlutusData) -> Proto Redeemer -> Proto Redeemer
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ((ScriptData, ByteString) -> Proto PlutusData)
-> Maybe (ScriptData, ByteString) -> Maybe (Proto PlutusData)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ScriptData -> Proto PlutusData
scriptDataToUtxoRpcPlutusData (ScriptData -> Proto PlutusData)
-> ((ScriptData, ByteString) -> ScriptData)
-> (ScriptData, ByteString)
-> Proto PlutusData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScriptData, ByteString) -> ScriptData
forall a b. (a, b) -> a
fst) Maybe (ScriptData, ByteString)
redeemerDatum
    Proto Redeemer
-> (Proto Redeemer -> Proto Redeemer) -> Proto Redeemer
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto Redeemer) ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "originalCbor" a) =>
LensLike' f s a
U5c.originalCbor LensLike' Identity (Proto Redeemer) ByteString
-> ByteString -> Proto Redeemer -> Proto Redeemer
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ByteString
-> ((ScriptData, ByteString) -> ByteString)
-> Maybe (ScriptData, ByteString)
-> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
forall a. Monoid a => a
mempty (ScriptData, ByteString) -> ByteString
forall a b. (a, b) -> b
snd Maybe (ScriptData, ByteString)
redeemerDatum

-- | Convert a 'ScriptExecutionError' into a proto 'EvalReport' with the
-- redeemer purpose and 0-based index that produced the error.
scriptExecutionErrorToEvalReport
  :: ScriptWitnessIndex -> ScriptExecutionError -> Proto UtxoRpc.EvalReport
scriptExecutionErrorToEvalReport :: ScriptWitnessIndex -> ScriptExecutionError -> Proto EvalReport
scriptExecutionErrorToEvalReport ScriptWitnessIndex
swi ScriptExecutionError
err = do
  let (Proto RedeemerPurpose
purpose, Word32
idx) = ScriptWitnessIndex -> (Proto RedeemerPurpose, Word32)
scriptWitnessIndexToRedeemerPurpose ScriptWitnessIndex
swi
  Proto EvalReport
forall msg. Message msg => msg
defMessage
    Proto EvalReport
-> (Proto EvalReport -> Proto EvalReport) -> Proto EvalReport
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto EvalReport) Text
forall (f :: * -> *) s a.
(Functor f, HasField s "msg" a) =>
LensLike' f s a
U5c.msg LensLike' Identity (Proto EvalReport) Text
-> Text -> Proto EvalReport -> Proto EvalReport
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ScriptExecutionError -> Text
forall a. Show a => a -> Text
tshow ScriptExecutionError
err
    Proto EvalReport
-> (Proto EvalReport -> Proto EvalReport) -> Proto EvalReport
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto EvalReport) (Proto RedeemerPurpose)
forall (f :: * -> *) s a.
(Functor f, HasField s "purpose" a) =>
LensLike' f s a
U5c.purpose LensLike' Identity (Proto EvalReport) (Proto RedeemerPurpose)
-> Proto RedeemerPurpose -> Proto EvalReport -> Proto EvalReport
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Proto RedeemerPurpose
purpose
    Proto EvalReport
-> (Proto EvalReport -> Proto EvalReport) -> Proto EvalReport
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto EvalReport) Word32
forall (f :: * -> *) s a.
(Functor f, HasField s "index" a) =>
LensLike' f s a
U5c.index LensLike' Identity (Proto EvalReport) Word32
-> Word32 -> Proto EvalReport -> Proto EvalReport
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32
idx

-- | Map a 'ScriptWitnessIndex' to the corresponding proto 'RedeemerPurpose'
-- and the numeric index within that purpose.
scriptWitnessIndexToRedeemerPurpose
  :: ScriptWitnessIndex -> (Proto UtxoRpc.RedeemerPurpose, Word32)
scriptWitnessIndexToRedeemerPurpose :: ScriptWitnessIndex -> (Proto RedeemerPurpose, Word32)
scriptWitnessIndexToRedeemerPurpose = \case
  ScriptWitnessIndexTxIn Word32
i -> (RedeemerPurpose -> Proto RedeemerPurpose
forall msg. msg -> Proto msg
Proto RedeemerPurpose
UtxoRpc.REDEEMER_PURPOSE_SPEND, Word32
i)
  ScriptWitnessIndexMint Word32
i -> (RedeemerPurpose -> Proto RedeemerPurpose
forall msg. msg -> Proto msg
Proto RedeemerPurpose
UtxoRpc.REDEEMER_PURPOSE_MINT, Word32
i)
  ScriptWitnessIndexCertificate Word32
i -> (RedeemerPurpose -> Proto RedeemerPurpose
forall msg. msg -> Proto msg
Proto RedeemerPurpose
UtxoRpc.REDEEMER_PURPOSE_CERT, Word32
i)
  ScriptWitnessIndexWithdrawal Word32
i -> (RedeemerPurpose -> Proto RedeemerPurpose
forall msg. msg -> Proto msg
Proto RedeemerPurpose
UtxoRpc.REDEEMER_PURPOSE_REWARD, Word32
i)
  ScriptWitnessIndexVoting Word32
i -> (RedeemerPurpose -> Proto RedeemerPurpose
forall msg. msg -> Proto msg
Proto RedeemerPurpose
UtxoRpc.REDEEMER_PURPOSE_VOTE, Word32
i)
  ScriptWitnessIndexProposing Word32
i -> (RedeemerPurpose -> Proto RedeemerPurpose
forall msg. msg -> Proto msg
Proto RedeemerPurpose
UtxoRpc.REDEEMER_PURPOSE_PROPOSE, Word32
i)