{-# LANGUAGE ConstraintKinds      #-}
{-# LANGUAGE DeriveAnyClass       #-}
{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE DerivingVia          #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE PatternSynonyms      #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns         #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Ledger.Index.Internal where

import Prelude hiding (lookup)

import Cardano.Api qualified as C
import Cardano.Api.Shelley qualified as C
import Cardano.Binary qualified as CBOR
import Cardano.Ledger.Alonzo.Scripts (ExUnits)
import Cardano.Ledger.Alonzo.Tx (IsValid (IsValid), ValidatedTx (ValidatedTx))
import Cardano.Ledger.Alonzo.TxWitness (RdmrPtr)
import Cardano.Ledger.Babbage (BabbageEra)
import Cardano.Ledger.Core (Tx)
import Cardano.Ledger.Crypto (StandardCrypto)
import Cardano.Ledger.Shelley.API (Validated, extractTx)
import Codec.Serialise (Serialise (..))
import Control.Lens (makePrisms)
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Map qualified as Map
import Data.Text (Text)
import GHC.Generics (Generic)
import Ledger.Orphans ()
import Ledger.Tx.CardanoAPI.Internal (CardanoTx, pattern CardanoEmulatorEraTx)
import Plutus.V1.Ledger.Scripts qualified as Scripts
import Prettyprinter (Pretty (..), hang, vsep, (<+>))
import Prettyprinter.Extras (PrettyShow (..))
import Prettyprinter.Util (reflow)

-- | A transaction on the blockchain.
-- Invalid transactions are still put on the chain to be able to collect fees.
newtype OnChainTx = OnChainTx { OnChainTx -> Validated (Tx EmulatorEra)
getOnChainTx :: Validated (Tx EmulatorEra) }
    deriving (OnChainTx -> OnChainTx -> Bool
(OnChainTx -> OnChainTx -> Bool)
-> (OnChainTx -> OnChainTx -> Bool) -> Eq OnChainTx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OnChainTx -> OnChainTx -> Bool
$c/= :: OnChainTx -> OnChainTx -> Bool
== :: OnChainTx -> OnChainTx -> Bool
$c== :: OnChainTx -> OnChainTx -> Bool
Eq, Int -> OnChainTx -> ShowS
[OnChainTx] -> ShowS
OnChainTx -> String
(Int -> OnChainTx -> ShowS)
-> (OnChainTx -> String)
-> ([OnChainTx] -> ShowS)
-> Show OnChainTx
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OnChainTx] -> ShowS
$cshowList :: [OnChainTx] -> ShowS
show :: OnChainTx -> String
$cshow :: OnChainTx -> String
showsPrec :: Int -> OnChainTx -> ShowS
$cshowsPrec :: Int -> OnChainTx -> ShowS
Show, (forall x. OnChainTx -> Rep OnChainTx x)
-> (forall x. Rep OnChainTx x -> OnChainTx) -> Generic OnChainTx
forall x. Rep OnChainTx x -> OnChainTx
forall x. OnChainTx -> Rep OnChainTx x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep OnChainTx x -> OnChainTx
$cfrom :: forall x. OnChainTx -> Rep OnChainTx x
Generic)

instance Serialise OnChainTx where
  encode :: OnChainTx -> Encoding
encode = ValidatedTx EmulatorEra -> Encoding
forall a. ToCBOR a => a -> Encoding
CBOR.toCBOR (ValidatedTx EmulatorEra -> Encoding)
-> (OnChainTx -> ValidatedTx EmulatorEra) -> OnChainTx -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (ValidatedTx EmulatorEra) -> ValidatedTx EmulatorEra
forall tx. Validated tx -> tx
extractTx (Validated (ValidatedTx EmulatorEra) -> ValidatedTx EmulatorEra)
-> (OnChainTx -> Validated (ValidatedTx EmulatorEra))
-> OnChainTx
-> ValidatedTx EmulatorEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnChainTx -> Validated (Tx EmulatorEra)
OnChainTx -> Validated (ValidatedTx EmulatorEra)
getOnChainTx -- For blockID
  decode :: Decoder s OnChainTx
decode = String -> Decoder s OnChainTx
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Not allowed to use `decode` on `OnChainTx`" -- Unused

eitherTx :: (CardanoTx -> r) -> (CardanoTx -> r) -> OnChainTx -> r
eitherTx :: (CardanoTx -> r) -> (CardanoTx -> r) -> OnChainTx -> r
eitherTx CardanoTx -> r
ifInvalid CardanoTx -> r
ifValid (Validated (ValidatedTx EmulatorEra) -> ValidatedTx EmulatorEra
forall tx. Validated tx -> tx
extractTx (Validated (ValidatedTx EmulatorEra) -> ValidatedTx EmulatorEra)
-> (OnChainTx -> Validated (ValidatedTx EmulatorEra))
-> OnChainTx
-> ValidatedTx EmulatorEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnChainTx -> Validated (Tx EmulatorEra)
OnChainTx -> Validated (ValidatedTx EmulatorEra)
getOnChainTx -> tx :: ValidatedTx EmulatorEra
tx@(ValidatedTx TxBody EmulatorEra
_ TxWitness EmulatorEra
_ (IsValid Bool
isValid) StrictMaybe (AuxiliaryData EmulatorEra)
_)) =
    let ctx :: CardanoTx
ctx = Tx BabbageEra -> CardanoTx
CardanoEmulatorEraTx (ShelleyBasedEra BabbageEra
-> Tx (ShelleyLedgerEra BabbageEra) -> Tx BabbageEra
forall era.
ShelleyBasedEra era -> Tx (ShelleyLedgerEra era) -> Tx era
C.ShelleyTx ShelleyBasedEra BabbageEra
C.ShelleyBasedEraBabbage Tx (ShelleyLedgerEra BabbageEra)
ValidatedTx EmulatorEra
tx)
    in if Bool
isValid then CardanoTx -> r
ifValid CardanoTx
ctx else CardanoTx -> r
ifInvalid CardanoTx
ctx

unOnChain :: OnChainTx -> CardanoTx
unOnChain :: OnChainTx -> CardanoTx
unOnChain = (CardanoTx -> CardanoTx)
-> (CardanoTx -> CardanoTx) -> OnChainTx -> CardanoTx
forall r. (CardanoTx -> r) -> (CardanoTx -> r) -> OnChainTx -> r
eitherTx CardanoTx -> CardanoTx
forall a. a -> a
id CardanoTx -> CardanoTx
forall a. a -> a
id

type EmulatorEra = BabbageEra StandardCrypto

-- | The UTxOs of a blockchain indexed by their references.
type UtxoIndex = C.UTxO C.BabbageEra

deriving newtype instance Semigroup (C.UTxO era)
deriving newtype instance Monoid (C.UTxO era)

-- | A reason why a transaction is invalid.
data ValidationError =
    TxOutRefNotFound C.TxIn
    -- ^ The transaction output consumed by a transaction input could not be found (either because it was already spent, or because
    -- there was no transaction with the given hash on the blockchain).
    | ScriptFailure Scripts.ScriptError
    -- ^ For pay-to-script outputs: evaluation of the validator script failed.
    | CardanoLedgerValidationError Text
    -- ^ An error from Cardano.Ledger validation
    | MaxCollateralInputsExceeded
    -- ^ Balancing failed, it needed more than the maximum number of collateral inputs
    deriving (ValidationError -> ValidationError -> Bool
(ValidationError -> ValidationError -> Bool)
-> (ValidationError -> ValidationError -> Bool)
-> Eq ValidationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidationError -> ValidationError -> Bool
$c/= :: ValidationError -> ValidationError -> Bool
== :: ValidationError -> ValidationError -> Bool
$c== :: ValidationError -> ValidationError -> Bool
Eq, Int -> ValidationError -> ShowS
[ValidationError] -> ShowS
ValidationError -> String
(Int -> ValidationError -> ShowS)
-> (ValidationError -> String)
-> ([ValidationError] -> ShowS)
-> Show ValidationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidationError] -> ShowS
$cshowList :: [ValidationError] -> ShowS
show :: ValidationError -> String
$cshow :: ValidationError -> String
showsPrec :: Int -> ValidationError -> ShowS
$cshowsPrec :: Int -> ValidationError -> ShowS
Show, (forall x. ValidationError -> Rep ValidationError x)
-> (forall x. Rep ValidationError x -> ValidationError)
-> Generic ValidationError
forall x. Rep ValidationError x -> ValidationError
forall x. ValidationError -> Rep ValidationError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ValidationError x -> ValidationError
$cfrom :: forall x. ValidationError -> Rep ValidationError x
Generic)
makePrisms ''ValidationError

instance FromJSON ValidationError
instance ToJSON ValidationError
deriving via (PrettyShow ValidationError) instance Pretty ValidationError

data ValidationPhase = Phase1 | Phase2 deriving (ValidationPhase -> ValidationPhase -> Bool
(ValidationPhase -> ValidationPhase -> Bool)
-> (ValidationPhase -> ValidationPhase -> Bool)
-> Eq ValidationPhase
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidationPhase -> ValidationPhase -> Bool
$c/= :: ValidationPhase -> ValidationPhase -> Bool
== :: ValidationPhase -> ValidationPhase -> Bool
$c== :: ValidationPhase -> ValidationPhase -> Bool
Eq, Int -> ValidationPhase -> ShowS
[ValidationPhase] -> ShowS
ValidationPhase -> String
(Int -> ValidationPhase -> ShowS)
-> (ValidationPhase -> String)
-> ([ValidationPhase] -> ShowS)
-> Show ValidationPhase
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidationPhase] -> ShowS
$cshowList :: [ValidationPhase] -> ShowS
show :: ValidationPhase -> String
$cshow :: ValidationPhase -> String
showsPrec :: Int -> ValidationPhase -> ShowS
$cshowsPrec :: Int -> ValidationPhase -> ShowS
Show, (forall x. ValidationPhase -> Rep ValidationPhase x)
-> (forall x. Rep ValidationPhase x -> ValidationPhase)
-> Generic ValidationPhase
forall x. Rep ValidationPhase x -> ValidationPhase
forall x. ValidationPhase -> Rep ValidationPhase x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ValidationPhase x -> ValidationPhase
$cfrom :: forall x. ValidationPhase -> Rep ValidationPhase x
Generic, Value -> Parser [ValidationPhase]
Value -> Parser ValidationPhase
(Value -> Parser ValidationPhase)
-> (Value -> Parser [ValidationPhase]) -> FromJSON ValidationPhase
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ValidationPhase]
$cparseJSONList :: Value -> Parser [ValidationPhase]
parseJSON :: Value -> Parser ValidationPhase
$cparseJSON :: Value -> Parser ValidationPhase
FromJSON, [ValidationPhase] -> Encoding
[ValidationPhase] -> Value
ValidationPhase -> Encoding
ValidationPhase -> Value
(ValidationPhase -> Value)
-> (ValidationPhase -> Encoding)
-> ([ValidationPhase] -> Value)
-> ([ValidationPhase] -> Encoding)
-> ToJSON ValidationPhase
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ValidationPhase] -> Encoding
$ctoEncodingList :: [ValidationPhase] -> Encoding
toJSONList :: [ValidationPhase] -> Value
$ctoJSONList :: [ValidationPhase] -> Value
toEncoding :: ValidationPhase -> Encoding
$ctoEncoding :: ValidationPhase -> Encoding
toJSON :: ValidationPhase -> Value
$ctoJSON :: ValidationPhase -> Value
ToJSON)
deriving via (PrettyShow ValidationPhase) instance Pretty ValidationPhase
type ValidationErrorInPhase = (ValidationPhase, ValidationError)
type ValidationSuccess = (RedeemerReport, Validated (Tx EmulatorEra))
type RedeemerReport = Map.Map RdmrPtr ([Text], ExUnits)

data ValidationResult
    = FailPhase1 !CardanoTx !ValidationError
    -- ^ A transaction failed to validate in phase 1.
    | FailPhase2 !OnChainTx !ValidationError !C.Value
    -- ^ A transaction failed to validate in phase 2. The @Value@ indicates the amount of collateral stored in the transaction.
    | Success !OnChainTx !RedeemerReport
    deriving stock (ValidationResult -> ValidationResult -> Bool
(ValidationResult -> ValidationResult -> Bool)
-> (ValidationResult -> ValidationResult -> Bool)
-> Eq ValidationResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidationResult -> ValidationResult -> Bool
$c/= :: ValidationResult -> ValidationResult -> Bool
== :: ValidationResult -> ValidationResult -> Bool
$c== :: ValidationResult -> ValidationResult -> Bool
Eq, Int -> ValidationResult -> ShowS
[ValidationResult] -> ShowS
ValidationResult -> String
(Int -> ValidationResult -> ShowS)
-> (ValidationResult -> String)
-> ([ValidationResult] -> ShowS)
-> Show ValidationResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidationResult] -> ShowS
$cshowList :: [ValidationResult] -> ShowS
show :: ValidationResult -> String
$cshow :: ValidationResult -> String
showsPrec :: Int -> ValidationResult -> ShowS
$cshowsPrec :: Int -> ValidationResult -> ShowS
Show, (forall x. ValidationResult -> Rep ValidationResult x)
-> (forall x. Rep ValidationResult x -> ValidationResult)
-> Generic ValidationResult
forall x. Rep ValidationResult x -> ValidationResult
forall x. ValidationResult -> Rep ValidationResult x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ValidationResult x -> ValidationResult
$cfrom :: forall x. ValidationResult -> Rep ValidationResult x
Generic)

makePrisms ''ValidationResult

data ValidationResultSimple
    = ValidationFailPhase1 !CardanoTx !ValidationError
    | ValidationFailPhase2 !CardanoTx !ValidationError !C.Value
    | ValidationSuccess !CardanoTx
    deriving stock (forall x. ValidationResultSimple -> Rep ValidationResultSimple x)
-> (forall x.
    Rep ValidationResultSimple x -> ValidationResultSimple)
-> Generic ValidationResultSimple
forall x. Rep ValidationResultSimple x -> ValidationResultSimple
forall x. ValidationResultSimple -> Rep ValidationResultSimple x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ValidationResultSimple x -> ValidationResultSimple
$cfrom :: forall x. ValidationResultSimple -> Rep ValidationResultSimple x
Generic
    deriving anyclass ([ValidationResultSimple] -> Encoding
[ValidationResultSimple] -> Value
ValidationResultSimple -> Encoding
ValidationResultSimple -> Value
(ValidationResultSimple -> Value)
-> (ValidationResultSimple -> Encoding)
-> ([ValidationResultSimple] -> Value)
-> ([ValidationResultSimple] -> Encoding)
-> ToJSON ValidationResultSimple
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ValidationResultSimple] -> Encoding
$ctoEncodingList :: [ValidationResultSimple] -> Encoding
toJSONList :: [ValidationResultSimple] -> Value
$ctoJSONList :: [ValidationResultSimple] -> Value
toEncoding :: ValidationResultSimple -> Encoding
$ctoEncoding :: ValidationResultSimple -> Encoding
toJSON :: ValidationResultSimple -> Value
$ctoJSON :: ValidationResultSimple -> Value
ToJSON, Value -> Parser [ValidationResultSimple]
Value -> Parser ValidationResultSimple
(Value -> Parser ValidationResultSimple)
-> (Value -> Parser [ValidationResultSimple])
-> FromJSON ValidationResultSimple
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ValidationResultSimple]
$cparseJSONList :: Value -> Parser [ValidationResultSimple]
parseJSON :: Value -> Parser ValidationResultSimple
$cparseJSON :: Value -> Parser ValidationResultSimple
FromJSON)

toValidationResultSimple :: ValidationResult -> ValidationResultSimple
toValidationResultSimple :: ValidationResult -> ValidationResultSimple
toValidationResultSimple (FailPhase1 CardanoTx
tx ValidationError
err)      = CardanoTx -> ValidationError -> ValidationResultSimple
ValidationFailPhase1 CardanoTx
tx ValidationError
err
toValidationResultSimple (FailPhase2 OnChainTx
vtx ValidationError
err Value
val) = CardanoTx -> ValidationError -> Value -> ValidationResultSimple
ValidationFailPhase2 (OnChainTx -> CardanoTx
unOnChain OnChainTx
vtx) ValidationError
err Value
val
toValidationResultSimple (Success OnChainTx
vtx RedeemerReport
_)          = CardanoTx -> ValidationResultSimple
ValidationSuccess (OnChainTx -> CardanoTx
unOnChain OnChainTx
vtx)

instance ToJSON ValidationResult where
    toJSON :: ValidationResult -> Value
toJSON = ValidationResultSimple -> Value
forall a. ToJSON a => a -> Value
toJSON (ValidationResultSimple -> Value)
-> (ValidationResult -> ValidationResultSimple)
-> ValidationResult
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidationResult -> ValidationResultSimple
toValidationResultSimple

instance FromJSON ValidationResult where
    parseJSON :: Value -> Parser ValidationResult
parseJSON = Value -> Parser ValidationResult
forall a. Monoid a => a
mempty -- Always fail, this instance isn't really used, but required by pab's logging framework.

instance Pretty ValidationResult where
    pretty :: ValidationResult -> Doc ann
pretty ValidationResult
res = Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
hang Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
        case ValidationResult
res of
            FailPhase1 CardanoTx
_ ValidationError
err   -> Doc ann
"Validation failed in phase 1:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ValidationError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ValidationError
err
            FailPhase2 OnChainTx
_ ValidationError
err Value
_ -> Doc ann
"Validation failed in phase 2:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> ValidationError -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ValidationError
err
            Success{}          -> Doc ann
"Validation success"
        Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: (Text -> Doc ann) -> [Text] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Doc ann
forall ann. Text -> Doc ann
reflow (ValidationResult -> [Text]
getEvaluationLogs ValidationResult
res)


cardanoTxFromValidationResult :: ValidationResult -> CardanoTx
cardanoTxFromValidationResult :: ValidationResult -> CardanoTx
cardanoTxFromValidationResult (FailPhase1 CardanoTx
tx ValidationError
_)    = CardanoTx
tx
cardanoTxFromValidationResult (FailPhase2 OnChainTx
vtx ValidationError
_ Value
_) = OnChainTx -> CardanoTx
unOnChain OnChainTx
vtx
cardanoTxFromValidationResult (Success OnChainTx
vtx RedeemerReport
_)      = OnChainTx -> CardanoTx
unOnChain OnChainTx
vtx

toOnChain :: ValidationResult -> Maybe OnChainTx
toOnChain :: ValidationResult -> Maybe OnChainTx
toOnChain (Success OnChainTx
tx RedeemerReport
_)      = OnChainTx -> Maybe OnChainTx
forall a. a -> Maybe a
Just OnChainTx
tx
toOnChain (FailPhase2 OnChainTx
tx ValidationError
_ Value
_) = OnChainTx -> Maybe OnChainTx
forall a. a -> Maybe a
Just OnChainTx
tx
toOnChain ValidationResult
_                   = Maybe OnChainTx
forall a. Maybe a
Nothing

-- | Get logs from evaluating plutus scripts.
getEvaluationLogs :: ValidationResult -> [Text]
getEvaluationLogs :: ValidationResult -> [Text]
getEvaluationLogs = \case
    Success OnChainTx
_ RedeemerReport
r        -> ((RdmrPtr, ([Text], ExUnits)) -> [Text])
-> [(RdmrPtr, ([Text], ExUnits))] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([Text], ExUnits) -> [Text]
forall a b. (a, b) -> a
fst (([Text], ExUnits) -> [Text])
-> ((RdmrPtr, ([Text], ExUnits)) -> ([Text], ExUnits))
-> (RdmrPtr, ([Text], ExUnits))
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RdmrPtr, ([Text], ExUnits)) -> ([Text], ExUnits)
forall a b. (a, b) -> b
snd) ([(RdmrPtr, ([Text], ExUnits))] -> [Text])
-> [(RdmrPtr, ([Text], ExUnits))] -> [Text]
forall a b. (a -> b) -> a -> b
$ RedeemerReport -> [(RdmrPtr, ([Text], ExUnits))]
forall k a. Map k a -> [(k, a)]
Map.toList RedeemerReport
r
    FailPhase1 CardanoTx
_ ValidationError
err   -> ValidationError -> [Text]
logs ValidationError
err
    FailPhase2 OnChainTx
_ ValidationError
err Value
_ -> ValidationError -> [Text]
logs ValidationError
err
    where
        logs :: ValidationError -> [Text]
logs = \case
            ScriptFailure (Scripts.EvaluationError [Text]
msgs String
_) -> [Text]
msgs
            ValidationError
_                                              -> []