{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Allegra.ScriptTranslation (
  testScriptPostTranslation,
) where

import Cardano.Ledger.Allegra (AllegraEra)
import Cardano.Ledger.Allegra.State
import Cardano.Ledger.Genesis (NoGenesis (..))
import Cardano.Ledger.Shelley (ShelleyEra)
import qualified Cardano.Ledger.Shelley.API as S
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (LedgerState (..))
import Cardano.Ledger.Shelley.Scripts (
  MultiSig,
  pattern RequireAllOf,
 )
import qualified Cardano.Ledger.Val as Val
import Cardano.Slotting.Slot (SlotNo (..))
import Control.Monad.Except (runExcept)
import Control.State.Transition.Extended (TRC (..))
import Data.Default (def)
import qualified Data.Map.Strict as Map
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import GHC.Stack
import Lens.Micro ((&), (.~))
import Test.Cardano.Ledger.Shelley.Utils (applySTSTest, runShelleyBase)
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase)

bootstrapTxId :: S.TxId
bootstrapTxId :: TxId
bootstrapTxId = forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody @ShelleyEra TxBody ShelleyEra
forall era. EraTxBody era => TxBody era
mkBasicTxBody

fromRight :: HasCallStack => Either e a -> a
fromRight :: forall e a. HasCallStack => Either e a -> a
fromRight (Right a
x) = a
x
fromRight Either e a
_ = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Expected Right"

script :: MultiSig ShelleyEra
script :: MultiSig ShelleyEra
script = StrictSeq (NativeScript ShelleyEra) -> NativeScript ShelleyEra
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf StrictSeq (NativeScript ShelleyEra)
StrictSeq (MultiSig ShelleyEra)
forall a. StrictSeq a
StrictSeq.empty

scriptHash :: S.ScriptHash
scriptHash :: ScriptHash
scriptHash = forall era. EraScript era => Script era -> ScriptHash
hashScript @ShelleyEra Script ShelleyEra
MultiSig ShelleyEra
script

testScriptPostTranslation :: TestTree
testScriptPostTranslation :: TestTree
testScriptPostTranslation =
  [Char] -> Assertion -> TestTree
testCase
    [Char]
"we should still be able to spend a translated script"
    (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ let addr :: Addr
addr =
            Network -> PaymentCredential -> StakeReference -> Addr
S.Addr
              Network
S.Testnet
              (ScriptHash -> PaymentCredential
forall (kr :: KeyRole). ScriptHash -> Credential kr
S.ScriptHashObj ScriptHash
scriptHash)
              StakeReference
S.StakeRefNull
          utxo :: UTxO ShelleyEra
utxo =
            Map TxIn (TxOut ShelleyEra) -> UTxO ShelleyEra
forall era. Map TxIn (TxOut era) -> UTxO era
S.UTxO (Map TxIn (TxOut ShelleyEra) -> UTxO ShelleyEra)
-> Map TxIn (TxOut ShelleyEra) -> UTxO ShelleyEra
forall a b. (a -> b) -> a -> b
$
              TxIn
-> ShelleyTxOut ShelleyEra -> Map TxIn (ShelleyTxOut ShelleyEra)
forall k a. k -> a -> Map k a
Map.singleton
                (TxId -> TxIx -> TxIn
S.TxIn TxId
bootstrapTxId TxIx
forall a. Bounded a => a
minBound)
                (Addr -> Value ShelleyEra -> ShelleyTxOut ShelleyEra
forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
S.ShelleyTxOut Addr
addr (Coin -> Value ShelleyEra
forall t s. Inject t s => t -> s
Val.inject (Integer -> Coin
S.Coin Integer
1)))
          env :: LedgerEnv AllegraEra
env =
            SlotNo
-> Maybe EpochNo
-> TxIx
-> PParams AllegraEra
-> ChainAccountState
-> LedgerEnv AllegraEra
forall era.
SlotNo
-> Maybe EpochNo
-> TxIx
-> PParams era
-> ChainAccountState
-> LedgerEnv era
S.LedgerEnv
              (Word64 -> SlotNo
SlotNo Word64
0)
              Maybe EpochNo
forall a. Maybe a
Nothing
              TxIx
forall a. Bounded a => a
minBound
              PParams AllegraEra
forall era. EraPParams era => PParams era
emptyPParams
              (Coin -> Coin -> ChainAccountState
ChainAccountState (Integer -> Coin
S.Coin Integer
0) (Integer -> Coin
S.Coin Integer
0))
          utxoStShelley :: UTxOState ShelleyEra
utxoStShelley = UTxOState ShelleyEra
forall a. Default a => a
def {S.utxosUtxo = utxo}
          utxoStAllegra :: UTxOState AllegraEra
utxoStAllegra = Either Void (UTxOState AllegraEra) -> UTxOState AllegraEra
forall e a. HasCallStack => Either e a -> a
fromRight (Either Void (UTxOState AllegraEra) -> UTxOState AllegraEra)
-> (Except Void (UTxOState AllegraEra)
    -> Either Void (UTxOState AllegraEra))
-> Except Void (UTxOState AllegraEra)
-> UTxOState AllegraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except Void (UTxOState AllegraEra)
-> Either Void (UTxOState AllegraEra)
forall e a. Except e a -> Either e a
runExcept (Except Void (UTxOState AllegraEra) -> UTxOState AllegraEra)
-> Except Void (UTxOState AllegraEra) -> UTxOState AllegraEra
forall a b. (a -> b) -> a -> b
$ forall era (f :: * -> *).
TranslateEra era f =>
TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
translateEra @AllegraEra TranslationContext AllegraEra
NoGenesis AllegraEra
forall era. NoGenesis era
NoGenesis UTxOState (PreviousEra AllegraEra)
UTxOState ShelleyEra
utxoStShelley
          txb :: TxBody ShelleyEra
txb =
            Set TxIn
-> StrictSeq (TxOut ShelleyEra)
-> StrictSeq (TxCert ShelleyEra)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update ShelleyEra)
-> StrictMaybe TxAuxDataHash
-> TxBody ShelleyEra
S.ShelleyTxBody
              (TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton (TxIn -> Set TxIn) -> TxIn -> Set TxIn
forall a b. (a -> b) -> a -> b
$ TxId -> TxIx -> TxIn
S.TxIn TxId
bootstrapTxId TxIx
forall a. Bounded a => a
minBound)
              StrictSeq (TxOut ShelleyEra)
StrictSeq (ShelleyTxOut ShelleyEra)
forall a. StrictSeq a
StrictSeq.empty
              StrictSeq (TxCert ShelleyEra)
StrictSeq (ShelleyTxCert ShelleyEra)
forall a. StrictSeq a
StrictSeq.empty
              (Map RewardAccount Coin -> Withdrawals
S.Withdrawals Map RewardAccount Coin
forall a. Monoid a => a
mempty)
              (Integer -> Coin
S.Coin Integer
1)
              (Word64 -> SlotNo
SlotNo Word64
1)
              StrictMaybe (Update ShelleyEra)
forall a. StrictMaybe a
S.SNothing
              StrictMaybe TxAuxDataHash
forall a. StrictMaybe a
S.SNothing
          wits :: ShelleyTxWits ShelleyEra
wits = TxWits ShelleyEra
forall era. EraTxWits era => TxWits era
mkBasicTxWits TxWits ShelleyEra
-> (TxWits ShelleyEra -> ShelleyTxWits ShelleyEra)
-> ShelleyTxWits ShelleyEra
forall a b. a -> (a -> b) -> b
& (Map ScriptHash (Script ShelleyEra)
 -> Identity (Map ScriptHash (Script ShelleyEra)))
-> TxWits ShelleyEra -> Identity (TxWits ShelleyEra)
(Map ScriptHash (Script ShelleyEra)
 -> Identity (Map ScriptHash (MultiSig ShelleyEra)))
-> TxWits ShelleyEra -> Identity (ShelleyTxWits ShelleyEra)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits ShelleyEra) (Map ScriptHash (Script ShelleyEra))
scriptTxWitsL ((Map ScriptHash (Script ShelleyEra)
  -> Identity (Map ScriptHash (MultiSig ShelleyEra)))
 -> TxWits ShelleyEra -> Identity (ShelleyTxWits ShelleyEra))
-> Map ScriptHash (MultiSig ShelleyEra)
-> TxWits ShelleyEra
-> ShelleyTxWits ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ScriptHash
-> MultiSig ShelleyEra -> Map ScriptHash (MultiSig ShelleyEra)
forall k a. k -> a -> Map k a
Map.singleton ScriptHash
scriptHash MultiSig ShelleyEra
script
          txs :: ShelleyTx ShelleyEra
txs = TxBody ShelleyEra
-> TxWits ShelleyEra
-> StrictMaybe (TxAuxData ShelleyEra)
-> ShelleyTx ShelleyEra
forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
S.ShelleyTx TxBody ShelleyEra
txb TxWits ShelleyEra
ShelleyTxWits ShelleyEra
wits StrictMaybe (TxAuxData ShelleyEra)
StrictMaybe (ShelleyTxAuxData ShelleyEra)
forall a. StrictMaybe a
S.SNothing
          txa :: ShelleyTx AllegraEra
txa = Either DecoderError (ShelleyTx AllegraEra) -> ShelleyTx AllegraEra
forall e a. HasCallStack => Either e a -> a
fromRight (Either DecoderError (ShelleyTx AllegraEra)
 -> ShelleyTx AllegraEra)
-> (Except DecoderError (ShelleyTx AllegraEra)
    -> Either DecoderError (ShelleyTx AllegraEra))
-> Except DecoderError (ShelleyTx AllegraEra)
-> ShelleyTx AllegraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except DecoderError (ShelleyTx AllegraEra)
-> Either DecoderError (ShelleyTx AllegraEra)
forall e a. Except e a -> Either e a
runExcept (Except DecoderError (ShelleyTx AllegraEra)
 -> ShelleyTx AllegraEra)
-> Except DecoderError (ShelleyTx AllegraEra)
-> ShelleyTx AllegraEra
forall a b. (a -> b) -> a -> b
$ forall era (f :: * -> *).
TranslateEra era f =>
TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
translateEra @AllegraEra TranslationContext AllegraEra
NoGenesis AllegraEra
forall era. NoGenesis era
NoGenesis ShelleyTx (PreviousEra AllegraEra)
ShelleyTx ShelleyEra
txs
          result :: Either
  (NonEmpty (ShelleyLedgerPredFailure AllegraEra))
  (LedgerState AllegraEra)
result =
            ShelleyBase
  (Either
     (NonEmpty (ShelleyLedgerPredFailure AllegraEra))
     (LedgerState AllegraEra))
-> Either
     (NonEmpty (ShelleyLedgerPredFailure AllegraEra))
     (LedgerState AllegraEra)
forall a. ShelleyBase a -> a
runShelleyBase (ShelleyBase
   (Either
      (NonEmpty (ShelleyLedgerPredFailure AllegraEra))
      (LedgerState AllegraEra))
 -> Either
      (NonEmpty (ShelleyLedgerPredFailure AllegraEra))
      (LedgerState AllegraEra))
-> ShelleyBase
     (Either
        (NonEmpty (ShelleyLedgerPredFailure AllegraEra))
        (LedgerState AllegraEra))
-> Either
     (NonEmpty (ShelleyLedgerPredFailure AllegraEra))
     (LedgerState AllegraEra)
forall a b. (a -> b) -> a -> b
$
              forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTSTest @(S.ShelleyLEDGER AllegraEra)
                ((Environment (ShelleyLEDGER AllegraEra),
 State (ShelleyLEDGER AllegraEra),
 Signal (ShelleyLEDGER AllegraEra))
-> TRC (ShelleyLEDGER AllegraEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (LedgerEnv AllegraEra
Environment (ShelleyLEDGER AllegraEra)
env, UTxOState AllegraEra
-> CertState AllegraEra -> LedgerState AllegraEra
forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState UTxOState AllegraEra
utxoStAllegra CertState AllegraEra
ShelleyCertState AllegraEra
forall a. Default a => a
def, ShelleyTx AllegraEra
Signal (ShelleyLEDGER AllegraEra)
txa))
       in case Either
  (NonEmpty (ShelleyLedgerPredFailure AllegraEra))
  (LedgerState AllegraEra)
result of
            Left NonEmpty (ShelleyLedgerPredFailure AllegraEra)
e -> [Char] -> Assertion
forall a. HasCallStack => [Char] -> a
error ([Char] -> Assertion) -> [Char] -> Assertion
forall a b. (a -> b) -> a -> b
$ NonEmpty (ShelleyLedgerPredFailure AllegraEra) -> [Char]
forall a. Show a => a -> [Char]
show NonEmpty (ShelleyLedgerPredFailure AllegraEra)
e
            Right LedgerState AllegraEra
_ -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()