{-# 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 = TxBody TopTx ShelleyEra -> TxId
forall era (l :: TxLevel). EraTxBody era => TxBody l era -> TxId
txIdTxBody (TxBody TopTx ShelleyEra -> TxId)
-> TxBody TopTx ShelleyEra -> TxId
forall a b. (a -> b) -> a -> b
$ forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
mkBasicTxBody @ShelleyEra @TopTx

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 =
  HasCallStack => [Char] -> Expectation -> TestTree
[Char] -> Expectation -> TestTree
testCase
    [Char]
"we should still be able to spend a translated script"
    (Expectation -> TestTree) -> Expectation -> 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 TopTx ShelleyEra
txb =
            Set TxIn
-> StrictSeq (TxOut ShelleyEra)
-> StrictSeq (TxCert ShelleyEra)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update ShelleyEra)
-> StrictMaybe TxAuxDataHash
-> TxBody TopTx 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 :: Tx TopTx ShelleyEra
txs = TxBody TopTx ShelleyEra -> Tx TopTx ShelleyEra
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l ShelleyEra -> Tx l ShelleyEra
mkBasicTx TxBody TopTx ShelleyEra
txb Tx TopTx ShelleyEra
-> (Tx TopTx ShelleyEra -> Tx TopTx ShelleyEra)
-> Tx TopTx ShelleyEra
forall a b. a -> (a -> b) -> b
& (TxWits ShelleyEra -> Identity (TxWits ShelleyEra))
-> Tx TopTx ShelleyEra -> Identity (Tx TopTx ShelleyEra)
(ShelleyTxWits ShelleyEra -> Identity (ShelleyTxWits ShelleyEra))
-> Tx TopTx ShelleyEra -> Identity (Tx TopTx ShelleyEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ShelleyEra) (TxWits ShelleyEra)
witsTxL ((ShelleyTxWits ShelleyEra -> Identity (ShelleyTxWits ShelleyEra))
 -> Tx TopTx ShelleyEra -> Identity (Tx TopTx ShelleyEra))
-> ShelleyTxWits ShelleyEra
-> Tx TopTx ShelleyEra
-> Tx TopTx ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ShelleyTxWits ShelleyEra
wits
          txa :: Tx TopTx AllegraEra
txa = Either DecoderError (Tx TopTx AllegraEra) -> Tx TopTx AllegraEra
forall e a. HasCallStack => Either e a -> a
fromRight (Either DecoderError (Tx TopTx AllegraEra) -> Tx TopTx AllegraEra)
-> (Except DecoderError (Tx TopTx AllegraEra)
    -> Either DecoderError (Tx TopTx AllegraEra))
-> Except DecoderError (Tx TopTx AllegraEra)
-> Tx TopTx AllegraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Except DecoderError (Tx TopTx AllegraEra)
-> Either DecoderError (Tx TopTx AllegraEra)
forall e a. Except e a -> Either e a
runExcept (Except DecoderError (Tx TopTx AllegraEra) -> Tx TopTx AllegraEra)
-> Except DecoderError (Tx TopTx AllegraEra) -> Tx TopTx 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 Tx TopTx (PreviousEra AllegraEra)
Tx TopTx 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, Tx TopTx AllegraEra
Signal (ShelleyLEDGER AllegraEra)
txa))
       in case Either
  (NonEmpty (ShelleyLedgerPredFailure AllegraEra))
  (LedgerState AllegraEra)
result of
            Left NonEmpty (ShelleyLedgerPredFailure AllegraEra)
e -> [Char] -> Expectation
forall a. HasCallStack => [Char] -> a
error ([Char] -> Expectation) -> [Char] -> Expectation
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
_ -> () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()