{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- | Figure 3: Functions related to scripts
--   Babbage Specification
module Cardano.Ledger.Babbage.Scripts where

import Cardano.Ledger.Alonzo.Data (Data)
import Cardano.Ledger.Alonzo.PlutusScriptApi (getSpendingTxIn)
import Cardano.Ledger.Alonzo.Tx
  ( ScriptPurpose (..),
    ValidatedTx (..),
    isTwoPhaseScriptAddressFromMap,
    txdats',
  )
import Cardano.Ledger.Alonzo.TxWitness (TxWitness, unTxDats)
import Cardano.Ledger.Babbage.TxBody
  ( Datum (..),
    TxOut (..),
    txOutData,
    txOutDataHash,
  )
import qualified Cardano.Ledger.Core as Core
import Cardano.Ledger.Era (Crypto, Era, ValidateScript (hashScript))
import Cardano.Ledger.Hashes (DataHash)
import Cardano.Ledger.Shelley.Scripts (ScriptHash (..))
import Cardano.Ledger.Shelley.UTxO (UTxO (..))
import Cardano.Ledger.TxIn (TxIn)
import Control.Applicative ((<|>))
import Control.SetAlgebra (eval, (◁))
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (SJust, SNothing))
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Records (HasField (..))

-- | Extract binary data either directly from the `Core.Tx` as an "inline datum"
-- or look it up in the witnesses by the hash.
getDatumBabbage ::
  ( Era era,
    Core.TxOut era ~ TxOut era,
    Core.Witnesses era ~ TxWitness era
  ) =>
  Core.Tx era ->
  UTxO era ->
  ScriptPurpose (Crypto era) ->
  Maybe (Data era)
getDatumBabbage :: Tx era
-> UTxO era -> ScriptPurpose (Crypto era) -> Maybe (Data era)
getDatumBabbage Tx era
tx (UTxO Map (TxIn (Crypto era)) (TxOut era)
m) ScriptPurpose (Crypto era)
sp = do
  TxIn (Crypto era)
txIn <- ScriptPurpose (Crypto era) -> Maybe (TxIn (Crypto era))
forall crypto. ScriptPurpose crypto -> Maybe (TxIn crypto)
getSpendingTxIn ScriptPurpose (Crypto era)
sp
  TxOut era
txOut <- TxIn (Crypto era)
-> Map (TxIn (Crypto era)) (TxOut era) -> Maybe (TxOut era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn (Crypto era)
txIn Map (TxIn (Crypto era)) (TxOut era)
Map (TxIn (Crypto era)) (TxOut era)
m
  let txOutDataFromWits :: Maybe (Data era)
txOutDataFromWits = do
        DataHash (Crypto era)
hash <- TxOut era -> Maybe (DataHash (Crypto era))
forall era. Era era => TxOut era -> Maybe (DataHash (Crypto era))
txOutDataHash TxOut era
txOut
        DataHash (Crypto era)
-> Map (DataHash (Crypto era)) (Data era) -> Maybe (Data era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup DataHash (Crypto era)
hash (TxDats era -> Map (DataHash (Crypto era)) (Data era)
forall era. TxDats era -> Map (DataHash (Crypto era)) (Data era)
unTxDats (TxWitness era -> TxDats era
forall era. TxWitness era -> TxDats era
txdats' (Tx era -> TxWitness era
forall k (x :: k) r a. HasField x r a => r -> a
getField @"wits" Tx era
tx)))
  TxOut era -> Maybe (Data era)
forall era. TxOut era -> Maybe (Data era)
txOutData TxOut era
txOut Maybe (Data era) -> Maybe (Data era) -> Maybe (Data era)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Data era)
txOutDataFromWits

-- Figure 3 of the Specification
{- txscripts tx utxo = txwitscripts tx ∪ {hash s ↦ s | ( , , , s) ∈ utxo (spendInputs tx ∪ refInputs tx)} -}

-- Uses of inputs in ‘txscripts’ and ‘neededScripts’
-- There are currently 3 sets of inputs (spending, collateral, reference). A particular TxInput
-- can appear in more than one of the sets. Even in all three at the same, but that may not be
-- a really useful case.
--
-- 1) Collateral inputs are only spent if phase two fails. Their corresponding TxOut can only have
--    Key (not Script) Pay credentials, so ‘neededScripts’ does not look there.
-- 2) Reference inputs are not spent in the current Tx, unless that same input also appears in one
--    of the other sets. If that is not the case, their credentials are never needed, so anyone can
--    access the inline datums and scripts in their corresponding TxOut, without needing any
--    authorizing credentials. So ‘neededScripts’ does not look there.
-- 3) Spending inputs are always spent. So their Pay credentials are always needed.
--
-- Compute a Map of (ScriptHash -> Script) for all Scripts found in a ValidatedTx.
-- Note we are interested in the actual scripts that might be run during the Utxow
-- rule. There are two places to look:
-- 1) The Script part of the Witnesses
-- 2) The reference scripts found in the TxOuts, pointed to by the spending and reference inputs
--    of the Tx.  Given such a TxOut, we look in the Pay credentials of the Addr of that TxOut.
--      A. We only look in the Pay credential of the TxOut, because the Stake credential plays
--         no role in the Utxow rule.
--      B. We don’t use the collateral inputs, because they only have key-locked Pay credentials
-- 3) Note that 'txscripts' includes both Plutus and Non-Plutus scripts
--
-- The flip side is 'ScriptsNeeded' which computes the ScriptHash of every Pay Credential
-- in spending and collateral inputs. Since reference inputs do not need to be authorized,
-- 'scriptsNeeded' does not look there.
-- It is an invariant that every such Credential points to some actual script found here.

babbageTxScripts ::
  forall era.
  ( ValidateScript era,
    HasField "referenceScript" (Core.TxOut era) (StrictMaybe (Core.Script era)),
    HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
    HasField "referenceInputs" (Core.TxBody era) (Set (TxIn (Crypto era)))
  ) =>
  UTxO era ->
  Core.Tx era ->
  Map.Map (ScriptHash (Crypto era)) (Core.Script era)
babbageTxScripts :: UTxO era -> Tx era -> Map (ScriptHash (Crypto era)) (Script era)
babbageTxScripts UTxO era
utxo Tx era
tx = Map (ScriptHash (Crypto era)) (Script era)
ans
  where
    txbody :: TxBody era
txbody = Tx era -> TxBody era
forall k (x :: k) r a. HasField x r a => r -> a
getField @"body" Tx era
tx
    ins :: Set (TxIn (Crypto era))
ins = TxBody era -> Set (TxIn (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"referenceInputs" TxBody era
txbody Set (TxIn (Crypto era))
-> Set (TxIn (Crypto era)) -> Set (TxIn (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` TxBody era -> Set (TxIn (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"inputs" TxBody era
txbody
    ans :: Map (ScriptHash (Crypto era)) (Script era)
ans = Map (ScriptHash (Crypto era)) (Script era)
-> Map (ScriptHash (Crypto era)) (Script era)
-> Map (ScriptHash (Crypto era)) (Script era)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (Set (TxIn (Crypto era))
-> UTxO era -> Map (ScriptHash (Crypto era)) (Script era)
forall era.
(ValidateScript era,
 HasField
   "referenceScript" (TxOut era) (StrictMaybe (Script era))) =>
Set (TxIn (Crypto era))
-> UTxO era -> Map (ScriptHash (Crypto era)) (Script era)
refScripts Set (TxIn (Crypto era))
ins UTxO era
utxo) (Tx era -> Map (ScriptHash (Crypto era)) (Script era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"scriptWits" Tx era
tx)

-- | Collect all the reference scripts found in the TxOuts, pointed to by some input.
refScripts ::
  forall era.
  (ValidateScript era, HasField "referenceScript" (Core.TxOut era) (StrictMaybe (Core.Script era))) =>
  Set (TxIn (Crypto era)) ->
  UTxO era ->
  Map.Map (ScriptHash (Crypto era)) (Core.Script era)
refScripts :: Set (TxIn (Crypto era))
-> UTxO era -> Map (ScriptHash (Crypto era)) (Script era)
refScripts Set (TxIn (Crypto era))
ins (UTxO Map (TxIn (Crypto era)) (TxOut era)
mp) = (Map (ScriptHash (Crypto era)) (Script era)
 -> TxOut era -> Map (ScriptHash (Crypto era)) (Script era))
-> Map (ScriptHash (Crypto era)) (Script era)
-> Map (TxIn (Crypto era)) (TxOut era)
-> Map (ScriptHash (Crypto era)) (Script era)
forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' Map (ScriptHash (Crypto era)) (Script era)
-> TxOut era -> Map (ScriptHash (Crypto era)) (Script era)
accum Map (ScriptHash (Crypto era)) (Script era)
forall k a. Map k a
Map.empty (Exp (Map (TxIn (Crypto era)) (TxOut era))
-> Map (TxIn (Crypto era)) (TxOut era)
forall s t. Embed s t => Exp t -> s
eval (Set (TxIn (Crypto era))
ins Set (TxIn (Crypto era))
-> Map (TxIn (Crypto era)) (TxOut era)
-> Exp (Map (TxIn (Crypto era)) (TxOut era))
forall k s1 s2 (f :: * -> * -> *) v.
(Ord k, HasExp s1 (Sett k ()), HasExp s2 (f k v)) =>
s1 -> s2 -> Exp (f k v)
◁ Map (TxIn (Crypto era)) (TxOut era)
mp))
  where
    accum :: Map (ScriptHash (Crypto era)) (Script era)
-> TxOut era -> Map (ScriptHash (Crypto era)) (Script era)
accum Map (ScriptHash (Crypto era)) (Script era)
ans TxOut era
txout =
      case TxOut era -> StrictMaybe (Script era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"referenceScript" TxOut era
txout of
        StrictMaybe (Script era)
SNothing -> Map (ScriptHash (Crypto era)) (Script era)
ans
        (SJust Script era
script) -> ScriptHash (Crypto era)
-> Script era
-> Map (ScriptHash (Crypto era)) (Script era)
-> Map (ScriptHash (Crypto era)) (Script era)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Script era -> ScriptHash (Crypto era)
forall era.
ValidateScript era =>
Script era -> ScriptHash (Crypto era)
hashScript @era Script era
script) Script era
script Map (ScriptHash (Crypto era)) (Script era)
ans

-- Compute two sets for all TwoPhase scripts in a Tx.
-- set 1) DataHashes for each Two phase Script in a TxIn that has a DataHash
-- set 2) TxIns that are TwoPhase scripts, and should have a DataHash but don't.
--        in Babbage, a TxOut with an inline Datum, does not need DataHash, so
--        it should not be added to set of Bad TxIn.
{- { h | (_ → (a,_,h)) ∈ txins tx ◁ utxo, isNonNativeScriptAddress tx a} -}
babbageInputDataHashes ::
  forall era.
  ( HasField "inputs" (Core.TxBody era) (Set (TxIn (Crypto era))),
    ValidateScript era,
    Core.TxOut era ~ TxOut era
  ) =>
  Map.Map (ScriptHash (Crypto era)) (Core.Script era) ->
  ValidatedTx era ->
  UTxO era ->
  (Set (DataHash (Crypto era)), Set (TxIn (Crypto era)))
babbageInputDataHashes :: Map (ScriptHash (Crypto era)) (Script era)
-> ValidatedTx era
-> UTxO era
-> (Set (DataHash (Crypto era)), Set (TxIn (Crypto era)))
babbageInputDataHashes Map (ScriptHash (Crypto era)) (Script era)
hashScriptMap ValidatedTx era
tx (UTxO Map (TxIn (Crypto era)) (TxOut era)
mp) =
  ((Set (DataHash (Crypto era)), Set (TxIn (Crypto era)))
 -> TxIn (Crypto era)
 -> TxOut era
 -> (Set (DataHash (Crypto era)), Set (TxIn (Crypto era))))
-> (Set (DataHash (Crypto era)), Set (TxIn (Crypto era)))
-> Map (TxIn (Crypto era)) (TxOut era)
-> (Set (DataHash (Crypto era)), Set (TxIn (Crypto era)))
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (Set (DataHash (Crypto era)), Set (TxIn (Crypto era)))
-> TxIn (Crypto era)
-> TxOut era
-> (Set (DataHash (Crypto era)), Set (TxIn (Crypto era)))
accum (Set (DataHash (Crypto era))
forall a. Set a
Set.empty, Set (TxIn (Crypto era))
forall a. Set a
Set.empty) Map (TxIn (Crypto era)) (TxOut era)
smallUtxo
  where
    txbody :: TxBody era
txbody = ValidatedTx era -> TxBody era
forall era. ValidatedTx era -> TxBody era
body ValidatedTx era
tx
    spendinputs :: Set (TxIn (Crypto era))
spendinputs = TxBody era -> Set (TxIn (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"inputs" TxBody era
txbody :: Set (TxIn (Crypto era))
    smallUtxo :: Map (TxIn (Crypto era)) (TxOut era)
smallUtxo = Exp (Map (TxIn (Crypto era)) (TxOut era))
-> Map (TxIn (Crypto era)) (TxOut era)
forall s t. Embed s t => Exp t -> s
eval (Set (TxIn (Crypto era))
spendinputs Set (TxIn (Crypto era))
-> Map (TxIn (Crypto era)) (TxOut era)
-> Exp (Map (TxIn (Crypto era)) (TxOut era))
forall k s1 s2 (f :: * -> * -> *) v.
(Ord k, HasExp s1 (Sett k ()), HasExp s2 (f k v)) =>
s1 -> s2 -> Exp (f k v)
◁ Map (TxIn (Crypto era)) (TxOut era)
Map (TxIn (Crypto era)) (TxOut era)
mp)
    accum :: (Set (DataHash (Crypto era)), Set (TxIn (Crypto era)))
-> TxIn (Crypto era)
-> TxOut era
-> (Set (DataHash (Crypto era)), Set (TxIn (Crypto era)))
accum ans :: (Set (DataHash (Crypto era)), Set (TxIn (Crypto era)))
ans@(!Set (DataHash (Crypto era))
hashSet, !Set (TxIn (Crypto era))
inputSet) TxIn (Crypto era)
txin TxOut era
txout =
      case TxOut era
txout of
        TxOut Addr (Crypto era)
addr Value era
_ Datum era
NoDatum StrictMaybe (Script era)
_ ->
          if Map (ScriptHash (Crypto era)) (Script era)
-> Addr (Crypto era) -> Bool
forall era.
ValidateScript era =>
Map (ScriptHash (Crypto era)) (Script era)
-> Addr (Crypto era) -> Bool
isTwoPhaseScriptAddressFromMap @era Map (ScriptHash (Crypto era)) (Script era)
hashScriptMap Addr (Crypto era)
addr
            then (Set (DataHash (Crypto era))
hashSet, TxIn (Crypto era)
-> Set (TxIn (Crypto era)) -> Set (TxIn (Crypto era))
forall a. Ord a => a -> Set a -> Set a
Set.insert TxIn (Crypto era)
txin Set (TxIn (Crypto era))
inputSet)
            else (Set (DataHash (Crypto era)), Set (TxIn (Crypto era)))
ans
        TxOut Addr (Crypto era)
addr Value era
_ (DatumHash DataHash (Crypto era)
dhash) StrictMaybe (Script era)
_ ->
          if Map (ScriptHash (Crypto era)) (Script era)
-> Addr (Crypto era) -> Bool
forall era.
ValidateScript era =>
Map (ScriptHash (Crypto era)) (Script era)
-> Addr (Crypto era) -> Bool
isTwoPhaseScriptAddressFromMap @era Map (ScriptHash (Crypto era)) (Script era)
hashScriptMap Addr (Crypto era)
addr
            then (DataHash (Crypto era)
-> Set (DataHash (Crypto era)) -> Set (DataHash (Crypto era))
forall a. Ord a => a -> Set a -> Set a
Set.insert DataHash (Crypto era)
dhash Set (DataHash (Crypto era))
hashSet, Set (TxIn (Crypto era))
inputSet)
            else (Set (DataHash (Crypto era)), Set (TxIn (Crypto era)))
ans
        -- Though it is somewhat odd to allow non-two-phase-scripts to include a datum,
        -- the Alonzo era already set the precedent with datum hashes, and several dapp
        -- developers see this as a helpful feature.
        TxOut Addr (Crypto era)
_ Value era
_ (Datum BinaryData era
_) StrictMaybe (Script era)
_ -> (Set (DataHash (Crypto era)), Set (TxIn (Crypto era)))
ans