{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | Infrastructure for generating STS Traces over any Era
module Test.Cardano.Ledger.Shelley.Generator.EraGen (
  genUtxo0,
  genesisId,
  EraGen (..),
  MinLEDGER_STS,
  MinCHAIN_STS,
  MinUTXO_STS,
  MinGenTxout (..),
  Label (..),
  Sets (..),
  someKeyPairs,
  allScripts,
  mkDummyHash,
)
where

import Cardano.Ledger.BaseTypes (Network (..), ShelleyBase, StrictMaybe)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Hashes (unsafeMakeSafeHash)
import Cardano.Ledger.Keys (WitVKey)
import Cardano.Ledger.Shelley.API (
  Addr (Addr),
  Block (..),
  Credential (ScriptHashObj),
  LedgerEnv,
  LedgerState,
  ShelleyLedgersEnv,
  StakeReference (StakeRefBase),
 )
import Cardano.Ledger.Shelley.LedgerState (StashedAVVMAddresses, UTxOState (..))
import Cardano.Ledger.Shelley.PParams (Update)
import Cardano.Ledger.Shelley.Rules (UtxoEnv)
import Cardano.Ledger.Shelley.TxBody (ShelleyEraTxBody, Withdrawals)
import Cardano.Ledger.TxIn (TxId (TxId), TxIn)
import Cardano.Ledger.UTxO (UTxO)
import Cardano.Protocol.TPraos.BHeader (BHeader)
import Cardano.Slotting.Slot (SlotNo)
import Control.State.Transition.Extended (STS (..))
import Data.Default (Default)
import Data.Map (Map)
import Data.Sequence (Seq)
import Data.Sequence.Strict (StrictSeq)
import Data.Set (Set)
import Lens.Micro
import Test.Cardano.Ledger.Binary.Random (mkDummyHash)
import Test.Cardano.Ledger.Core.KeyPair (KeyPairs, mkAddr)
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto)
import Test.Cardano.Ledger.Shelley.Constants (Constants (..))
import Test.Cardano.Ledger.Shelley.Generator.Core (
  GenEnv (..),
  ScriptInfo,
  TwoPhase2ArgInfo (..),
  TwoPhase3ArgInfo (..),
  genesisCoins,
 )
import Test.Cardano.Ledger.Shelley.Generator.ScriptClass (
  ScriptClass,
  baseScripts,
  combinedScripts,
  keyPairs,
 )
import Test.Cardano.Ledger.Shelley.Rules.Chain (CHAIN, ChainState)
import Test.Cardano.Ledger.Shelley.Utils (Split)
import Test.QuickCheck (Gen, choose, shuffle)

{------------------------------------------------------------------------------
 An EraGen instance makes it possible to run the Shelley property tests. The idea
 is to generate (not fully) random Transactions, i.e. with enough coherency to be
 a real transaction, but which are strung together into Traces. In each step of the trace
 one of these (not fully) random transactions is applied. The idea is that some property should
 hold on any trace. Because we want these tests to work in any Era there are two things
 to consider:
 1) A Transaction generator needs to be parametric over all Eras.
 2) Since the Internals of the STS rules differ from Era to Era, the STS instances
    must also adapt to many Eras.

 To account for the "not fully" random nature of tranactions we use the type GenEnv which
 holds enough information to build "not fully" random transactions that are still coherent.

 For Transactions, we account for these differences by using the type families found in
 Cardano.Ledger.Core and other modules, and by a set of Era specific generators encoded
 in the EraGen class. Generally there is some "method" in the class for each type family.

 For traces we use the "class HasTrace (CHAIN era) (GenEnv era)"

 The following constraints encode the minimal properties needed to build a chain for
 any Era. It should be an invariant that these properties hold for all Eras (Shelley, Allegra, Mary, Alonzo ...)
 If we introduce a new Era, where they do not hold, we must adjust these things, so they do.
 1) Add a new type family
 2) Add new methods to EraGen
 3) Change the minimal constraints, so that they now hold for all Eras
 4) Change the generators to use the new methods.

 -----------------------------------------------------------------------------}

-- | Minimal requirements on the LEDGER and LEDGERS instances
type MinLEDGER_STS era =
  ( Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era
  , BaseM (EraRule "LEDGER" era) ~ ShelleyBase
  , Signal (EraRule "LEDGER" era) ~ Tx era
  , State (EraRule "LEDGER" era) ~ LedgerState era
  , Environment (EraRule "LEDGER" era) ~ LedgerEnv era
  , BaseM (EraRule "LEDGERS" era) ~ ShelleyBase
  , State (EraRule "LEDGERS" era) ~ LedgerState era
  , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era)
  , STS (EraRule "LEDGER" era)
  )

-- | Minimal requirements on the CHAIN instances
type MinCHAIN_STS era =
  ( STS (CHAIN era)
  , BaseM (CHAIN era) ~ ShelleyBase
  , Environment (CHAIN era) ~ ()
  , State (CHAIN era) ~ ChainState era
  , Signal (CHAIN era) ~ Block (BHeader MockCrypto) era
  )

-- | Minimal requirements on the UTxO instances
type MinUTXO_STS era =
  ( STS (EraRule "UTXOW" era)
  , BaseM (EraRule "UTXOW" era) ~ ShelleyBase
  , State (EraRule "UTXOW" era) ~ UTxOState era
  , Environment (EraRule "UTXOW" era) ~ UtxoEnv era
  , Signal (EraRule "UTXOW" era) ~ Tx era
  , State (EraRule "UTXO" era) ~ UTxOState era
  , Environment (EraRule "UTXO" era) ~ UtxoEnv era
  , Signal (EraRule "UTXO" era) ~ Tx era
  )

class Show (TxOut era) => MinGenTxout era where
  calcEraMinUTxO :: TxOut era -> PParams era -> Coin
  addValToTxOut :: Value era -> TxOut era -> TxOut era
  genEraTxOut :: GenEnv era -> Gen (Value era) -> [Addr] -> Gen [TxOut era]

-- ======================================================================================
-- The EraGen class. Generally one method for each type family in Cardano.Ledger.Core
-- ======================================================================================

class
  ( EraSegWits era
  , ShelleyEraTxBody era
  , Split (Value era)
  , ScriptClass era
  , EraPParams era
  , MinGenTxout era
  , Default (StashedAVVMAddresses era)
  ) =>
  EraGen era
  where
  -- | Generate a genesis value for the Era
  genGenesisValue :: GenEnv era -> Gen (Value era)

  -- | A list of three-phase scripts that can be chosen for payment when building a transaction
  genEraTwoPhase3Arg :: [TwoPhase3ArgInfo era]
  genEraTwoPhase3Arg = []

  -- | A list of two-phase scripts that can be chosen for Delegating, Minting, or Rewarding when building a transaction
  genEraTwoPhase2Arg :: [TwoPhase2ArgInfo era]
  genEraTwoPhase2Arg = []

  -- | Given some pre-generated data, generate an era-specific TxBody,
  -- and a list of additional scripts for eras that sometimes require
  -- additional script witnessing.
  genEraTxBody ::
    GenEnv era ->
    UTxO era ->
    PParams era ->
    SlotNo ->
    Set TxIn ->
    StrictSeq (TxOut era) ->
    StrictSeq (TxCert era) ->
    Withdrawals ->
    Coin ->
    StrictMaybe (Update era) ->
    StrictMaybe TxAuxDataHash ->
    Gen (TxBody era, [Script era])

  -- | Generate era-specific auxiliary data
  genEraAuxiliaryData :: Constants -> Gen (StrictMaybe (TxAuxData era))

  -- | Update an era-specific TxBody
  updateEraTxBody ::
    UTxO era ->
    PParams era ->
    TxWits era ->
    TxBody era ->
    Coin ->
    -- | This overrides the existing TxFee
    Set TxIn ->
    -- | This is to be Unioned with the existing TxIn
    TxOut era ->
    -- | This is to be Appended to the end of the existing TxOut
    TxBody era

  -- |  Union the TxIn with the existing TxIn in the TxBody
  addInputs :: TxBody era -> Set TxIn -> TxBody era
  addInputs TxBody era
txb Set TxIn
_ins = TxBody era
txb

  genEraPParamsUpdate :: Constants -> PParams era -> Gen (PParamsUpdate era)

  genEraPParams :: Constants -> Gen (PParams era)

  -- Its is VERY IMPORTANT that the decentralisation parameter "_d" be non-zero and less than 1.
  -- The system will deadlock if d==0 and there are no registered stake pools.
  -- use Test.Cardano.Ledger.Shelley.Generator.Update(genDecentralisationParam) in your instance.

  genEraTxWits ::
    (UTxO era, TxBody era, ScriptInfo era) ->
    Set (WitVKey 'Witness) ->
    Map ScriptHash (Script era) ->
    TxWits era

  -- When choosing new recipients from the UTxO, choose only those whose Outputs meet this predicate.
  genEraGoodTxOut :: TxOut era -> Bool
  genEraGoodTxOut TxOut era
_ = Bool
True -- The default implementation marks every TxOut as good.

  -- | Construct a transaction given its constituent parts.
  constructTx ::
    TxBody era ->
    TxWits era ->
    StrictMaybe (TxAuxData era) ->
    Tx era
  constructTx TxBody era
txBody TxWits era
txWits StrictMaybe (TxAuxData era)
txAuxData =
    forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
txBody forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxWits era
txWits forall a b. a -> (a -> b) -> b
& forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (TxAuxData era))
auxDataTxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe (TxAuxData era)
txAuxData

  -- | compute the delta cost of an additional script on  per Era basis.
  genEraScriptCost :: PParams era -> Script era -> Coin
  genEraScriptCost PParams era
_pp Script era
_script = Integer -> Coin
Coin Integer
0

  -- | A final opportunity to tweak things when the generator is done. Possible uses
  --   1) Add tracing when debugging on a per Era basis
  genEraDone :: UTxO era -> PParams era -> Tx era -> Gen (Tx era)
  genEraDone UTxO era
_utxo PParams era
_pp Tx era
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx era
x

  -- | A final opportunity to tweak things at the block level. Possible uses
  --   2) Run a test that might decide to 'discard' the test, because we got unlucky, and a rare unfixible condition has occurred.
  genEraTweakBlock :: PParams era -> Seq (Tx era) -> Gen (Seq (Tx era))
  genEraTweakBlock PParams era
_pp Seq (Tx era)
seqTx = forall (f :: * -> *) a. Applicative f => a -> f a
pure Seq (Tx era)
seqTx

  hasFailedScripts :: Tx era -> Bool
  hasFailedScripts = forall a b. a -> b -> a
const Bool
False

  feeOrCollateral :: Tx era -> UTxO era -> Coin
  feeOrCollateral Tx era
tx UTxO era
_ = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL

{------------------------------------------------------------------------------
  Generators shared across eras
 -----------------------------------------------------------------------------}

-- | Select between _lower_ and _upper_ keys from 'keyPairs'
someKeyPairs :: Constants -> (Int, Int) -> Gen KeyPairs
someKeyPairs :: Constants -> (Int, Int) -> Gen KeyPairs
someKeyPairs Constants
c (Int, Int)
range = forall a. Int -> [a] -> [a]
take forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (Int, Int)
range forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. [a] -> Gen [a]
shuffle (Constants -> KeyPairs
keyPairs Constants
c)

genUtxo0 :: forall era. EraGen era => GenEnv era -> Gen (UTxO era)
genUtxo0 :: forall era. EraGen era => GenEnv era -> Gen (UTxO era)
genUtxo0 ge :: GenEnv era
ge@(GenEnv KeySpace era
_ ScriptSpace era
_ c :: Constants
c@Constants {Int
minGenesisUTxOouts :: Constants -> Int
minGenesisUTxOouts :: Int
minGenesisUTxOouts, Int
maxGenesisUTxOouts :: Constants -> Int
maxGenesisUTxOouts :: Int
maxGenesisUTxOouts}) = do
  let range :: (Int, Int)
range = (Int
minGenesisUTxOouts forall a. Integral a => a -> a -> a
`div` Int
2, Int
maxGenesisUTxOouts forall a. Integral a => a -> a -> a
`div` Int
2)
  KeyPairs
genesisKeys <- Constants -> (Int, Int) -> Gen KeyPairs
someKeyPairs Constants
c (Int, Int)
range
  [(Script era, Script era)]
genesisScripts <- forall era.
EraGen era =>
Constants -> (Int, Int) -> Gen [(Script era, Script era)]
someScripts @era Constants
c (Int, Int)
range
  [TxOut era]
outs <-
    (forall era.
MinGenTxout era =>
GenEnv era -> Gen (Value era) -> [Addr] -> Gen [TxOut era]
genEraTxOut @era GenEnv era
ge)
      (forall era. EraGen era => GenEnv era -> Gen (Value era)
genGenesisValue @era GenEnv era
ge)
      (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (KeyPair 'Payment, KeyPair 'Staking) -> Addr
mkAddr KeyPairs
genesisKeys forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Network -> (Script era, Script era) -> Addr
scriptsmkAddr' Network
Testnet) [(Script era, Script era)]
genesisScripts)
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall era. TxId -> [TxOut era] -> UTxO era
genesisCoins TxId
genesisId [TxOut era]
outs)
  where
    scriptsmkAddr' :: Network -> (Script era, Script era) -> Addr
    scriptsmkAddr' :: Network -> (Script era, Script era) -> Addr
scriptsmkAddr' Network
n (Script era
payScript, Script era
stakeScript) =
      Network -> PaymentCredential -> StakeReference -> Addr
Addr Network
n (forall (kr :: KeyRole). Script era -> Credential kr
scriptToCred' Script era
payScript) (StakeCredential -> StakeReference
StakeRefBase forall a b. (a -> b) -> a -> b
$ forall (kr :: KeyRole). Script era -> Credential kr
scriptToCred' Script era
stakeScript)

    scriptToCred' :: Script era -> Credential kr
    scriptToCred' :: forall (kr :: KeyRole). Script era -> Credential kr
scriptToCred' = forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraScript era => Script era -> ScriptHash
hashScript @era

-- | We share this dummy TxId as genesis transaction id across eras
genesisId :: TxId
genesisId :: TxId
genesisId = SafeHash EraIndependentTxBody -> TxId
TxId (forall i. Hash HASH i -> SafeHash i
unsafeMakeSafeHash (forall h a b. (HashAlgorithm h, EncCBOR a) => a -> Hash h b
mkDummyHash (Int
0 :: Int)))

-- ==========================================================

-- | Select between _lower_ and _upper_ scripts from the possible combinations
-- of the first `numBaseScripts` multi-sig scripts of `mSigScripts` (i.e compound scripts) AND
-- some simple scripts (NOT compound. ie either signature or Plutus scripts).
someScripts ::
  forall era.
  EraGen era =>
  Constants ->
  (Int, Int) ->
  Gen [(Script era, Script era)]
someScripts :: forall era.
EraGen era =>
Constants -> (Int, Int) -> Gen [(Script era, Script era)]
someScripts Constants
c (Int, Int)
range = forall a. Int -> [a] -> [a]
take forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (Int, Int)
range forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. [a] -> Gen [a]
shuffle (forall era. EraGen era => Constants -> [(Script era, Script era)]
allScripts @era Constants
c)

-- | A list of all possible kinds of scripts in the current Era.
--   Might include Keylocked scripts, Start-Finish Timelock scripts, Quantified scripts (All, Any, MofN), Plutus Scripts
--   Note that 'genEraTwoPhase3Arg' and 'genEraTwoPhase2Arg' may be the empty list ([]) in some Eras.
allScripts :: forall era. EraGen era => Constants -> [(Script era, Script era)]
allScripts :: forall era. EraGen era => Constants -> [(Script era, Script era)]
allScripts Constants
c =
  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [(Script era, Script era)]
plutusPairs
    , forall a. Int -> [a] -> [a]
take (Constants -> Int
numSimpleScripts Constants
c) [(Script era, Script era)]
simpleScripts -- 10 means about 5% of allScripts are Plutus Scripts
    -- Plutus scripts in some Eras ([] in other Eras)
    -- [(payment,staking)] where the either payment or staking may be a plutus script
    -- Simple scripts (key locked, Start-Finish timelocks)
    , forall era.
ScriptClass era =>
Constants -> [(Script era, Script era)]
combinedScripts @era Constants
c
    ]
  where
    simpleScripts :: [(Script era, Script era)]
simpleScripts = forall era.
ScriptClass era =>
Constants -> [(Script era, Script era)]
baseScripts @era Constants
c
    plutusPairs :: [(Script era, Script era)]
    plutusPairs :: [(Script era, Script era)]
plutusPairs = do
      Script era
script3 <- forall era. TwoPhase3ArgInfo era -> Script era
getScript3 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era. EraGen era => [TwoPhase3ArgInfo era]
genEraTwoPhase3Arg
      Script era
script2 <- forall era. TwoPhase2ArgInfo era -> Script era
getScript2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era. EraGen era => [TwoPhase2ArgInfo era]
genEraTwoPhase2Arg
      (Script era
payment, Script era
staking) <- forall a. Int -> [a] -> [a]
take Int
3 [(Script era, Script era)]
simpleScripts
      [(Script era
script3, Script era
staking), (Script era
payment, Script era
script2), (Script era
script3, Script era
script2)]

-- =========================================================

data Label t where
  Body' :: Label (TxBody era)
  Wits' :: Label (TxWits era)

class Sets (x :: Label t) y where
  set :: Label t -> y -> y