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

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

import Cardano.Ledger.Allegra (Allegra)
import Cardano.Ledger.Crypto (StandardCrypto)
import Cardano.Ledger.Genesis (NoGenesis (..))
import Cardano.Ledger.Shelley (Shelley)
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.Class (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 StandardCrypto
bootstrapTxId :: TxId StandardCrypto
bootstrapTxId = forall era. EraTxBody era => TxBody era -> TxId (EraCrypto era)
txIdTxBody @Shelley 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
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"Expected Right"

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

scriptHash :: S.ScriptHash StandardCrypto
scriptHash :: ScriptHash StandardCrypto
scriptHash = forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
hashScript @Shelley MultiSig (ShelleyEra StandardCrypto)
script

testScriptPostTranslation :: TestTree
testScriptPostTranslation :: TestTree
testScriptPostTranslation =
  [Char] -> Assertion -> TestTree
testCase
    [Char]
"we should still be able to spend a translated script"
    forall a b. (a -> b) -> a -> b
$ let addr :: Addr StandardCrypto
addr =
            forall c.
Network -> PaymentCredential c -> StakeReference c -> Addr c
S.Addr
              Network
S.Testnet
              (forall (kr :: KeyRole) c. ScriptHash c -> Credential kr c
S.ScriptHashObj ScriptHash StandardCrypto
scriptHash)
              forall c. StakeReference c
S.StakeRefNull
          utxo :: UTxO (ShelleyEra StandardCrypto)
utxo =
            forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
S.UTxO forall a b. (a -> b) -> a -> b
$
              forall k a. k -> a -> Map k a
Map.singleton
                (forall c. TxId c -> TxIx -> TxIn c
S.TxIn TxId StandardCrypto
bootstrapTxId forall a. Bounded a => a
minBound)
                (forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
S.ShelleyTxOut Addr StandardCrypto
addr (forall t s. Inject t s => t -> s
Val.inject (Integer -> Coin
S.Coin Integer
1)))
          env :: LedgerEnv (AllegraEra StandardCrypto)
env = forall era.
SlotNo
-> TxIx -> PParams era -> AccountState -> Bool -> LedgerEnv era
S.LedgerEnv (Word64 -> SlotNo
SlotNo Word64
0) forall a. Bounded a => a
minBound forall era. EraPParams era => PParams era
emptyPParams (Coin -> Coin -> AccountState
S.AccountState (Integer -> Coin
S.Coin Integer
0) (Integer -> Coin
S.Coin Integer
0)) Bool
False
          utxoStShelley :: UTxOState (ShelleyEra StandardCrypto)
utxoStShelley = forall a. Default a => a
def {utxosUtxo :: UTxO (ShelleyEra StandardCrypto)
S.utxosUtxo = UTxO (ShelleyEra StandardCrypto)
utxo}
          utxoStAllegra :: UTxOState (AllegraEra StandardCrypto)
utxoStAllegra = forall e a. HasCallStack => Either e a -> a
fromRight forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Except e a -> Either e a
runExcept 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 @Allegra forall era. NoGenesis era
NoGenesis UTxOState (ShelleyEra StandardCrypto)
utxoStShelley
          txb :: ShelleyTxBody (ShelleyEra StandardCrypto)
txb =
            forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set (TxIn (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> ShelleyTxBody era
S.ShelleyTxBody
              (forall a. a -> Set a
Set.singleton forall a b. (a -> b) -> a -> b
$ forall c. TxId c -> TxIx -> TxIn c
S.TxIn TxId StandardCrypto
bootstrapTxId forall a. Bounded a => a
minBound)
              forall a. StrictSeq a
StrictSeq.empty
              forall a. StrictSeq a
StrictSeq.empty
              (forall c. Map (RewardAcnt c) Coin -> Withdrawals c
S.Withdrawals forall a. Monoid a => a
mempty)
              (Integer -> Coin
S.Coin Integer
1)
              (Word64 -> SlotNo
SlotNo Word64
1)
              forall a. StrictMaybe a
S.SNothing
              forall a. StrictMaybe a
S.SNothing
          wits :: ShelleyTxWits (ShelleyEra StandardCrypto)
wits = forall era. EraTxWits era => TxWits era
mkBasicTxWits forall a b. a -> (a -> b) -> b
& forall era.
EraTxWits era =>
Lens' (TxWits era) (Map (ScriptHash (EraCrypto era)) (Script era))
scriptTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall k a. k -> a -> Map k a
Map.singleton ScriptHash StandardCrypto
scriptHash MultiSig (ShelleyEra StandardCrypto)
script
          txs :: ShelleyTx (ShelleyEra StandardCrypto)
txs = forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
S.ShelleyTx ShelleyTxBody (ShelleyEra StandardCrypto)
txb ShelleyTxWits (ShelleyEra StandardCrypto)
wits forall a. StrictMaybe a
S.SNothing
          txa :: ShelleyTx (AllegraEra StandardCrypto)
txa = forall e a. HasCallStack => Either e a -> a
fromRight forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Except e a -> Either e a
runExcept 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 @Allegra forall era. NoGenesis era
NoGenesis ShelleyTx (ShelleyEra StandardCrypto)
txs
          result :: Either
  (NonEmpty (ShelleyLedgerPredFailure (AllegraEra StandardCrypto)))
  (LedgerState (AllegraEra StandardCrypto))
result =
            forall a. ShelleyBase a -> a
runShelleyBase 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 Allegra)
                (forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (LedgerEnv (AllegraEra StandardCrypto)
env, forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState UTxOState (AllegraEra StandardCrypto)
utxoStAllegra forall a. Default a => a
def, ShelleyTx (AllegraEra StandardCrypto)
txa))
       in case Either
  (NonEmpty (ShelleyLedgerPredFailure (AllegraEra StandardCrypto)))
  (LedgerState (AllegraEra StandardCrypto))
result of
            Left NonEmpty (ShelleyLedgerPredFailure (AllegraEra StandardCrypto))
e -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show NonEmpty (ShelleyLedgerPredFailure (AllegraEra StandardCrypto))
e
            Right LedgerState (AllegraEra StandardCrypto)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()