{-# 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.Address (Addr)
import Cardano.Ledger.BaseTypes (ShelleyBase, StrictMaybe)
import Cardano.Ledger.Block (Block (..))
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Hashes (unsafeMakeSafeHash)
import Cardano.Ledger.Keys (WitVKey)
import Cardano.Ledger.Shelley.API (
  LedgerEnv,
  LedgerState,
  ShelleyLedgersEnv,
 )
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.State (EraCertState, UTxO)
import Cardano.Ledger.TxIn (TxId (TxId), TxIn)
import Cardano.Protocol.TPraos.BHeader (BHeader)
import Cardano.Slotting.Slot (SlotNo)
import Control.State.Transition.Extended (STS (..))
import Data.Bifunctor (bimap)
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 TopTx 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 TopTx 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 TopTx era
  , State (EraRule "UTXO" era) ~ UTxOState era
  , Environment (EraRule "UTXO" era) ~ UtxoEnv era
  , Signal (EraRule "UTXO" era) ~ Tx TopTx era
  )

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

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

class
  ( EraBlockBody era
  , ShelleyEraTxBody era
  , Split (Value era)
  , ScriptClass era
  , EraPParams era
  , MinGenTxout era
  , Default (StashedAVVMAddresses era)
  , EraCertState era
  ) =>
  EraGen era
  where
  -- | Generate a genesis value for the Era
  genGenesisValue :: GenEnv c 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 c era ->
    UTxO era ->
    PParams era ->
    SlotNo ->
    Set TxIn ->
    StrictSeq (TxOut era) ->
    StrictSeq (TxCert era) ->
    Withdrawals ->
    Coin ->
    StrictMaybe (Update era) ->
    StrictMaybe TxAuxDataHash ->
    Gen (TxBody TopTx 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 TopTx 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 TopTx era

  -- |  Union the TxIn with the existing TxIn in the TxBody
  addInputs :: TxBody TopTx era -> Set TxIn -> TxBody TopTx era
  addInputs TxBody TopTx era
txb Set TxIn
_ins = TxBody TopTx 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 TopTx 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 TopTx era ->
    TxWits era ->
    StrictMaybe (TxAuxData era) ->
    Tx TopTx era
  constructTx TxBody TopTx era
txBody TxWits era
txWits StrictMaybe (TxAuxData era)
txAuxData =
    TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
txBody Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxWits era -> Identity (TxWits era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era -> Identity (TxWits era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> TxWits era -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxWits era
txWits Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (TxAuxData era)
 -> Identity (StrictMaybe (TxAuxData era)))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
forall (l :: TxLevel).
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
auxDataTxL ((StrictMaybe (TxAuxData era)
  -> Identity (StrictMaybe (TxAuxData era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictMaybe (TxAuxData era) -> Tx TopTx era -> Tx TopTx era
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 TopTx era -> Gen (Tx TopTx era)
  genEraDone UTxO era
_utxo PParams era
_pp Tx TopTx era
x = Tx TopTx era -> Gen (Tx TopTx era)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx TopTx 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 TopTx era) -> Gen (Seq (Tx TopTx era))
  genEraTweakBlock PParams era
_pp Seq (Tx TopTx era)
seqTx = Seq (Tx TopTx era) -> Gen (Seq (Tx TopTx era))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Seq (Tx TopTx era)
seqTx

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

  feeOrCollateral :: Tx TopTx era -> UTxO era -> Coin
  feeOrCollateral Tx TopTx era
tx UTxO era
_ = Tx TopTx era
tx Tx TopTx era -> Getting Coin (Tx TopTx era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (TxBody TopTx era -> Const Coin (TxBody TopTx era))
-> Tx TopTx era -> Const Coin (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Const Coin (TxBody TopTx era))
 -> Tx TopTx era -> Const Coin (Tx TopTx era))
-> ((Coin -> Const Coin Coin)
    -> TxBody TopTx era -> Const Coin (TxBody TopTx era))
-> Getting Coin (Tx TopTx era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin)
-> TxBody TopTx era -> Const Coin (TxBody TopTx era)
forall era. EraTxBody era => Lens' (TxBody TopTx era) Coin
Lens' (TxBody TopTx 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 = Int -> KeyPairs -> KeyPairs
forall a. Int -> [a] -> [a]
take (Int -> KeyPairs -> KeyPairs)
-> Gen Int -> Gen (KeyPairs -> KeyPairs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int, Int)
range Gen (KeyPairs -> KeyPairs) -> Gen KeyPairs -> Gen KeyPairs
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KeyPairs -> Gen KeyPairs
forall a. [a] -> Gen [a]
shuffle (Constants -> KeyPairs
keyPairs Constants
c)

genUtxo0 :: forall era c. EraGen era => GenEnv c era -> Gen (UTxO era)
genUtxo0 :: forall era c. EraGen era => GenEnv c era -> Gen (UTxO era)
genUtxo0 ge :: GenEnv c era
ge@(GenEnv KeySpace c era
_ ScriptSpace era
_ c :: Constants
c@Constants {Int
minGenesisUTxOouts :: Int
minGenesisUTxOouts :: Constants -> Int
minGenesisUTxOouts, Int
maxGenesisUTxOouts :: Int
maxGenesisUTxOouts :: Constants -> Int
maxGenesisUTxOouts}) = do
  let range :: (Int, Int)
range = (Int
minGenesisUTxOouts Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2, Int
maxGenesisUTxOouts Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
  genesisKeys <- Constants -> (Int, Int) -> Gen KeyPairs
someKeyPairs Constants
c (Int, Int)
range
  genesisScripts <- someScripts @era c range
  outs <-
    genEraTxOut ge (genGenesisValue ge) $
      fmap (uncurry mkAddr) genesisKeys
        ++ fmap (uncurry mkAddr . bimap hashScript hashScript) genesisScripts
  return (genesisCoins genesisId outs)

-- | We share this dummy TxId as genesis transaction id across eras
genesisId :: TxId
genesisId :: TxId
genesisId = SafeHash EraIndependentTxBody -> TxId
TxId (Hash HASH EraIndependentTxBody -> SafeHash EraIndependentTxBody
forall i. Hash HASH i -> SafeHash i
unsafeMakeSafeHash (Int -> Hash HASH EraIndependentTxBody
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 = Int -> [(Script era, Script era)] -> [(Script era, Script era)]
forall a. Int -> [a] -> [a]
take (Int -> [(Script era, Script era)] -> [(Script era, Script era)])
-> Gen Int
-> Gen ([(Script era, Script era)] -> [(Script era, Script era)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int, Int)
range Gen ([(Script era, Script era)] -> [(Script era, Script era)])
-> Gen [(Script era, Script era)] -> Gen [(Script era, Script era)]
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(Script era, Script era)] -> Gen [(Script era, Script era)]
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 =
  [[(Script era, Script era)]] -> [(Script era, Script era)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [(Script era, Script era)]
plutusPairs
    , Int -> [(Script era, Script era)] -> [(Script era, Script era)]
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
      script3 <- TwoPhase3ArgInfo era -> Script era
forall era. TwoPhase3ArgInfo era -> Script era
getScript3 (TwoPhase3ArgInfo era -> Script era)
-> [TwoPhase3ArgInfo era] -> [Script era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TwoPhase3ArgInfo era]
forall era. EraGen era => [TwoPhase3ArgInfo era]
genEraTwoPhase3Arg
      script2 <- getScript2 <$> genEraTwoPhase2Arg
      (payment, staking) <- take 3 simpleScripts
      [(script3, staking), (payment, script2), (script3, script2)]

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

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

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