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

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

import Cardano.Ledger.Allegra (AllegraEra)
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 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 ShelleyEra
script :: MultiSig ShelleyEra
script = forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf forall a. StrictSeq a
StrictSeq.empty

scriptHash :: S.ScriptHash
scriptHash :: ScriptHash
scriptHash = forall era. EraScript era => Script era -> ScriptHash
hashScript @ShelleyEra MultiSig ShelleyEra
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
addr =
            Network -> PaymentCredential -> StakeReference -> Addr
S.Addr
              Network
S.Testnet
              (forall (kr :: KeyRole). ScriptHash -> Credential kr
S.ScriptHashObj ScriptHash
scriptHash)
              StakeReference
S.StakeRefNull
          utxo :: UTxO ShelleyEra
utxo =
            forall era. Map TxIn (TxOut era) -> UTxO era
S.UTxO forall a b. (a -> b) -> a -> b
$
              forall k a. k -> a -> Map k a
Map.singleton
                (TxId -> TxIx -> TxIn
S.TxIn TxId
bootstrapTxId forall a. Bounded a => a
minBound)
                (forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
S.ShelleyTxOut Addr
addr (forall t s. Inject t s => t -> s
Val.inject (Integer -> Coin
S.Coin Integer
1)))
          env :: LedgerEnv AllegraEra
env =
            forall era.
SlotNo
-> Maybe EpochNo
-> TxIx
-> PParams era
-> AccountState
-> Bool
-> LedgerEnv era
S.LedgerEnv
              (Word64 -> SlotNo
SlotNo Word64
0)
              forall a. Maybe a
Nothing
              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
utxoStShelley = forall a. Default a => a
def {utxosUtxo :: UTxO ShelleyEra
S.utxosUtxo = UTxO ShelleyEra
utxo}
          utxoStAllegra :: UTxOState AllegraEra
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 @AllegraEra forall era. NoGenesis era
NoGenesis UTxOState ShelleyEra
utxoStShelley
          txb :: ShelleyTxBody ShelleyEra
txb =
            forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> ShelleyTxBody era
S.ShelleyTxBody
              (forall a. a -> Set a
Set.singleton forall a b. (a -> b) -> a -> b
$ TxId -> TxIx -> TxIn
S.TxIn TxId
bootstrapTxId forall a. Bounded a => a
minBound)
              forall a. StrictSeq a
StrictSeq.empty
              forall a. StrictSeq a
StrictSeq.empty
              (Map RewardAccount Coin -> Withdrawals
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
wits = forall era. EraTxWits era => TxWits era
mkBasicTxWits forall a b. a -> (a -> b) -> b
& forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (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
scriptHash MultiSig ShelleyEra
script
          txs :: ShelleyTx ShelleyEra
txs = forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
S.ShelleyTx ShelleyTxBody ShelleyEra
txb ShelleyTxWits ShelleyEra
wits forall a. StrictMaybe a
S.SNothing
          txa :: ShelleyTx AllegraEra
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 @AllegraEra forall era. NoGenesis era
NoGenesis ShelleyTx ShelleyEra
txs
          result :: Either
  (NonEmpty (ShelleyLedgerPredFailure AllegraEra))
  (LedgerState AllegraEra)
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 AllegraEra)
                (forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (LedgerEnv AllegraEra
env, forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState UTxOState AllegraEra
utxoStAllegra forall a. Default a => a
def, ShelleyTx AllegraEra
txa))
       in case Either
  (NonEmpty (ShelleyLedgerPredFailure AllegraEra))
  (LedgerState AllegraEra)
result of
            Left NonEmpty (ShelleyLedgerPredFailure AllegraEra)
e -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show NonEmpty (ShelleyLedgerPredFailure AllegraEra)
e
            Right LedgerState AllegraEra
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()