{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Cardano.Ledger.Shelley.Generator.Core (
  AllIssuerKeys (..),
  VRFKeyPair (..),
  KESKeyPair (..),
  GenEnv (..),
  ScriptSpace (..),
  TwoPhase3ArgInfo (..),
  TwoPhase2ArgInfo (..),
  ScriptInfo,
  KeySpace (..),
  pattern KeySpace,
  NatNonce (..),
  findPayKeyPairAddr,
  findPayKeyPairCred,
  findPayScriptFromCred,
  findStakeScriptFromCred,
  findPayScriptFromAddr,
  genBool,
  genCoinList,
  genInteger,
  genNatural,
  genWord64,
  genTxOut,
  genesisCoins,
  increasingProbabilityAt,
  pickStakeKey,
  mkAddr,
  mkCred,
  mkBlock,
  mkBlockFakeVRF,
  mkOCert,
  getKESPeriodRenewalNo,
  tooLateInEpoch,
  RawSeed (..),
  mkKeyPair,
  mkKeyPairs,
  mkGenKey,
  genesisAccountState,
  genCoin,
  PreAlonzo,
  hashData,
  findPlutus,
)
where

import qualified Cardano.Crypto.Hash as Hash
import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.BaseTypes (StrictMaybe (..), epochInfoPure, stabilityWindow)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (
  Credential (..),
  pattern KeyHashObj,
  pattern ScriptHashObj,
  pattern StakeRefBase,
  pattern StakeRefPtr,
 )
import Cardano.Ledger.Hashes (unsafeMakeSafeHash)
import Cardano.Ledger.Keys (VKey, asWitness)
import Cardano.Ledger.Shelley.LedgerState (AccountState (..))
import Cardano.Ledger.Shelley.TxWits (ShelleyTxWits)
import Cardano.Ledger.Slot (
  Duration (..),
  SlotNo (..),
  epochInfoFirst,
  (*-),
 )
import Cardano.Ledger.TxIn (TxId, TxIn (TxIn))
import Cardano.Ledger.UTxO (UTxO (UTxO))
import Cardano.Protocol.TPraos.OCert (KESPeriod (..))
import Codec.Serialise (serialise)
import Control.Monad (replicateM)
import Control.Monad.Trans.Reader (asks)
import Data.ByteString.Lazy (toStrict)
import qualified Data.List.NonEmpty as NE
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Word (Word64)
import Numeric.Natural (Natural)
import qualified PlutusLedgerApi.V1 as PV1
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), KeyPairs, mkAddr, mkCred, vKey)
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto)
import Test.Cardano.Ledger.Shelley.Constants (Constants (..))
import Test.Cardano.Ledger.Shelley.Generator.ScriptClass (
  ScriptClass,
  exponential,
  mkKeyPairs,
  mkPayScriptHashMap,
  mkStakeScriptHashMap,
 )
import Test.Cardano.Ledger.Shelley.Utils (
  GenesisKeyPair,
  RawSeed (..),
  epochFromSlotNo,
  maxKESIterations,
  maxLLSupply,
  mkGenKey,
  mkKeyPair,
  runShelleyBase,
 )
import Test.Cardano.Protocol.Crypto.VRF.Fake (NatNonce (..))
import Test.Cardano.Protocol.TPraos.Create (
  AllIssuerKeys (..),
  KESKeyPair (..),
  VRFKeyPair (..),
  mkBlock,
  mkBlockFakeVRF,
  mkOCert,
 )
import Test.Cardano.Slotting.Numeric ()
import Test.QuickCheck (Gen)
import qualified Test.QuickCheck as QC

-- | For use in the Serialisation and Example Tests, which assume Shelley, Allegra, or Mary Eras.
type PreAlonzo era =
  (TxWits era ~ ShelleyTxWits era)

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

type ScriptInfo era =
  ( Map ScriptHash (TwoPhase3ArgInfo era)
  , Map ScriptHash (TwoPhase2ArgInfo era)
  )

data TwoPhase3ArgInfo era = TwoPhase3ArgInfo
  { forall era. TwoPhase3ArgInfo era -> Script era
getScript3 :: Script era
  -- ^ A Plutus Script
  , forall era. TwoPhase3ArgInfo era -> ScriptHash
getHash3 :: ScriptHash
  -- ^ Its ScriptHash
  , forall era. TwoPhase3ArgInfo era -> Data
getData3 :: PV1.Data
  -- ^ A Data that will make it succeed
  , forall era. TwoPhase3ArgInfo era -> (Data, Natural, Natural)
getRedeemer3 ::
      ( PV1.Data -- The redeeming data
      , Natural -- The ExUnits memory count
      , Natural -- The ExUnits steps count
      )
  -- ^ A Redeemer that will make it succeed
  , forall era. TwoPhase3ArgInfo era -> Bool
getSucceeds3 :: Bool
  }

data TwoPhase2ArgInfo era = TwoPhase2ArgInfo
  { forall era. TwoPhase2ArgInfo era -> Script era
getScript2 :: Script era
  -- ^ A Plutus Script
  , forall era. TwoPhase2ArgInfo era -> ScriptHash
getHash2 :: ScriptHash
  -- ^ Its ScriptHash
  , forall era. TwoPhase2ArgInfo era -> (Data, Natural, Natural)
getRedeemer2 ::
      ( PV1.Data -- The redeeming data
      , Natural -- The ExUnits memory count
      , Natural -- The ExUnits steps count
      )
  -- ^ A Redeemer that will make it succeed
  , forall era. TwoPhase2ArgInfo era -> Bool
getSucceeds2 :: Bool
  }

deriving instance Show (Script era) => Show (TwoPhase3ArgInfo era)

deriving instance Show (Script era) => Show (TwoPhase2ArgInfo era)

data ScriptSpace era = ScriptSpace
  { forall era. ScriptSpace era -> [TwoPhase3ArgInfo era]
ssScripts3 :: [TwoPhase3ArgInfo era]
  -- ^ A list of Two Phase 3 Arg Scripts and their associated data we can use.
  , forall era. ScriptSpace era -> [TwoPhase2ArgInfo era]
ssScripts2 :: [TwoPhase2ArgInfo era]
  -- ^ A list of Two Phase 2 Arg Scripts and their associated data we can use.
  , forall era.
ScriptSpace era -> Map ScriptHash (TwoPhase3ArgInfo era)
ssHash3 :: Map ScriptHash (TwoPhase3ArgInfo era)
  , forall era.
ScriptSpace era -> Map ScriptHash (TwoPhase2ArgInfo era)
ssHash2 :: Map ScriptHash (TwoPhase2ArgInfo era)
  }

deriving instance Show (Script era) => Show (ScriptSpace era)

-- | Generator environment.
data GenEnv era = GenEnv
  { forall era. GenEnv era -> KeySpace era
geKeySpace :: KeySpace era
  , forall era. GenEnv era -> ScriptSpace era
geScriptSpapce :: ScriptSpace era
  , forall era. GenEnv era -> Constants
geConstants :: Constants
  }

-- | Collection of all keys which are required to generate a trace.
--
--   These are the _only_ keys which should be involved in the trace.
data KeySpace era = KeySpace_
  { forall era.
KeySpace era
-> [(GenesisKeyPair MockCrypto,
     AllIssuerKeys MockCrypto 'GenesisDelegate)]
ksCoreNodes :: [(GenesisKeyPair MockCrypto, AllIssuerKeys MockCrypto 'GenesisDelegate)]
  , forall era.
KeySpace era -> [AllIssuerKeys MockCrypto 'GenesisDelegate]
ksGenesisDelegates :: [AllIssuerKeys MockCrypto 'GenesisDelegate]
  -- ^ Bag of keys to be used for future genesis delegates
  , forall era. KeySpace era -> [AllIssuerKeys MockCrypto 'StakePool]
ksStakePools :: [AllIssuerKeys MockCrypto 'StakePool]
  -- ^ Bag of keys to be used for future stake pools
  , forall era. KeySpace era -> KeyPairs
ksKeyPairs :: KeyPairs
  -- ^ Bag of keys to be used for future payment/staking addresses
  , forall era. KeySpace era -> [(Script era, Script era)]
ksMSigScripts :: [(Script era, Script era)]
  , forall era.
KeySpace era -> Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys :: Map (KeyHash 'Payment) (KeyPair 'Payment)
  -- ^ Index over the payment keys in 'ksKeyPairs'
  , forall era.
KeySpace era -> Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys :: Map (KeyHash 'Staking) (KeyPair 'Staking)
  -- ^ Index over the staking keys in 'ksKeyPairs'
  , forall era.
KeySpace era
-> Map
     (KeyHash 'GenesisDelegate)
     (AllIssuerKeys MockCrypto 'GenesisDelegate)
ksIndexedGenDelegates ::
      Map (KeyHash 'GenesisDelegate) (AllIssuerKeys MockCrypto 'GenesisDelegate)
  -- ^ Index over the cold key hashes in Genesis Delegates
  , forall era. KeySpace era -> Map ScriptHash (Script era, Script era)
ksIndexedPayScripts :: Map ScriptHash (Script era, Script era)
  -- ^ Index over the pay script hashes in Script pairs
  , forall era. KeySpace era -> Map ScriptHash (Script era, Script era)
ksIndexedStakeScripts :: Map ScriptHash (Script era, Script era)
  -- ^ Index over the stake script hashes in Script pairs
  }

deriving instance (Era era, Show (Script era)) => Show (KeySpace era)

pattern KeySpace ::
  forall era.
  ScriptClass era =>
  [(GenesisKeyPair MockCrypto, AllIssuerKeys MockCrypto 'GenesisDelegate)] ->
  [AllIssuerKeys MockCrypto 'GenesisDelegate] ->
  [AllIssuerKeys MockCrypto 'StakePool] ->
  KeyPairs ->
  [(Script era, Script era)] ->
  KeySpace era
pattern $bKeySpace :: forall era.
ScriptClass era =>
[(GenesisKeyPair MockCrypto,
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
-> [AllIssuerKeys MockCrypto 'GenesisDelegate]
-> [AllIssuerKeys MockCrypto 'StakePool]
-> KeyPairs
-> [(Script era, Script era)]
-> KeySpace era
$mKeySpace :: forall {r} {era}.
ScriptClass era =>
KeySpace era
-> ([(GenesisKeyPair MockCrypto,
      AllIssuerKeys MockCrypto 'GenesisDelegate)]
    -> [AllIssuerKeys MockCrypto 'GenesisDelegate]
    -> [AllIssuerKeys MockCrypto 'StakePool]
    -> KeyPairs
    -> [(Script era, Script era)]
    -> r)
-> ((# #) -> r)
-> r
KeySpace
  ksCoreNodes
  ksGenesisDelegates
  ksStakePools
  ksKeyPairs
  ksMSigScripts <-
  KeySpace_
    { ksCoreNodes
    , ksGenesisDelegates
    , ksStakePools
    , ksKeyPairs
    , ksMSigScripts
    }
  where
    KeySpace [(GenesisKeyPair MockCrypto,
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
ksCoreNodes [AllIssuerKeys MockCrypto 'GenesisDelegate]
ksGenesisDelegates [AllIssuerKeys MockCrypto 'StakePool]
ksStakePools KeyPairs
ksKeyPairs [(Script era, Script era)]
ksMSigScripts =
      KeySpace_
        { [(GenesisKeyPair MockCrypto,
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
ksCoreNodes :: [(GenesisKeyPair MockCrypto,
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
ksCoreNodes :: [(GenesisKeyPair MockCrypto,
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
ksCoreNodes
        , [AllIssuerKeys MockCrypto 'GenesisDelegate]
ksGenesisDelegates :: [AllIssuerKeys MockCrypto 'GenesisDelegate]
ksGenesisDelegates :: [AllIssuerKeys MockCrypto 'GenesisDelegate]
ksGenesisDelegates
        , [AllIssuerKeys MockCrypto 'StakePool]
ksStakePools :: [AllIssuerKeys MockCrypto 'StakePool]
ksStakePools :: [AllIssuerKeys MockCrypto 'StakePool]
ksStakePools
        , KeyPairs
ksKeyPairs :: KeyPairs
ksKeyPairs :: KeyPairs
ksKeyPairs
        , ksIndexedPaymentKeys :: Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys = KeyPairs -> Map (KeyHash 'Payment) (KeyPair 'Payment)
mkPayKeyHashMap KeyPairs
ksKeyPairs
        , ksIndexedStakingKeys :: Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys = KeyPairs -> Map (KeyHash 'Staking) (KeyPair 'Staking)
mkStakeKeyHashMap KeyPairs
ksKeyPairs
        , ksIndexedGenDelegates :: Map
  (KeyHash 'GenesisDelegate)
  (AllIssuerKeys MockCrypto 'GenesisDelegate)
ksIndexedGenDelegates = forall c.
[(GenesisKeyPair MockCrypto, AllIssuerKeys c 'GenesisDelegate)]
-> [AllIssuerKeys c 'GenesisDelegate]
-> Map
     (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
mkGenesisDelegatesHashMap [(GenesisKeyPair MockCrypto,
  AllIssuerKeys MockCrypto 'GenesisDelegate)]
ksCoreNodes [AllIssuerKeys MockCrypto 'GenesisDelegate]
ksGenesisDelegates
        , ksIndexedPayScripts :: Map ScriptHash (Script era, Script era)
ksIndexedPayScripts = forall era.
ScriptClass era =>
[(Script era, Script era)]
-> Map ScriptHash (Script era, Script era)
mkPayScriptHashMap @era [(Script era, Script era)]
ksMSigScripts
        , ksIndexedStakeScripts :: Map ScriptHash (Script era, Script era)
ksIndexedStakeScripts = forall era.
ScriptClass era =>
[(Script era, Script era)]
-> Map ScriptHash (Script era, Script era)
mkStakeScriptHashMap @era [(Script era, Script era)]
ksMSigScripts
        , [(Script era, Script era)]
ksMSigScripts :: [(Script era, Script era)]
ksMSigScripts :: [(Script era, Script era)]
ksMSigScripts
        }

genCoin :: Integer -> Integer -> Gen Coin
genCoin :: Integer -> Integer -> Gen Coin
genCoin Integer
minCoin Integer
maxCoin = Integer -> Coin
Coin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Integer -> Gen Integer
exponential Integer
minCoin Integer
maxCoin

genBool :: Gen Bool
genBool :: Gen Bool
genBool = forall a. (Bounded a, Random a) => Gen a
QC.arbitraryBoundedRandom

genInteger :: Integer -> Integer -> Gen Integer
genInteger :: Integer -> Integer -> Gen Integer
genInteger Integer
lower Integer
upper = forall a. Random a => (a, a) -> Gen a
QC.choose (Integer
lower, Integer
upper)

-- | Generator for a natural number between 'lower' and 'upper'
genNatural :: Natural -> Natural -> Gen Natural
genNatural :: Natural -> Natural -> Gen Natural
genNatural Natural
lower Natural
upper = forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
QC.choose (Integer
lower', Integer
upper')
  where
    lower' :: Integer
lower' = forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
lower
    upper' :: Integer
upper' = forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
upper

-- | Generator for a Word64 between 'lower' and 'upper'
genWord64 :: Word64 -> Word64 -> Gen Word64
genWord64 :: Word64 -> Word64 -> Gen Word64
genWord64 Word64
lower Word64
upper =
  forall a b. (Integral a, Num b) => a -> b
fromIntegral
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> Natural -> Gen Natural
genNatural (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
lower) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
upper)

-- | Generate a mapping from genesis delegate cold key hash to the issuer keys.
-- Note: we index all possible genesis delegate keys, that is,
-- core nodes and all potential keys.
mkGenesisDelegatesHashMap ::
  [(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)] ->
  [AllIssuerKeys c 'GenesisDelegate] ->
  Map (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
mkGenesisDelegatesHashMap :: forall c.
[(GenesisKeyPair MockCrypto, AllIssuerKeys c 'GenesisDelegate)]
-> [AllIssuerKeys c 'GenesisDelegate]
-> Map
     (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
mkGenesisDelegatesHashMap [(GenesisKeyPair MockCrypto, AllIssuerKeys c 'GenesisDelegate)]
coreNodes [AllIssuerKeys c 'GenesisDelegate]
genesisDelegates =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall {c} {kd :: KeyRole}.
AllIssuerKeys c kd -> (KeyHash kd, AllIssuerKeys c kd)
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AllIssuerKeys c 'GenesisDelegate]
allDelegateKeys)
  where
    f :: AllIssuerKeys c kd -> (KeyHash kd, AllIssuerKeys c kd)
f AllIssuerKeys c kd
issuerKeys = (forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey forall a b. (a -> b) -> a -> b
$ forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold AllIssuerKeys c kd
issuerKeys, AllIssuerKeys c kd
issuerKeys)
    allDelegateKeys :: [AllIssuerKeys c 'GenesisDelegate]
allDelegateKeys = (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(GenesisKeyPair MockCrypto, AllIssuerKeys c 'GenesisDelegate)]
coreNodes) forall a. Semigroup a => a -> a -> a
<> [AllIssuerKeys c 'GenesisDelegate]
genesisDelegates

-- | Generate a mapping from stake key hash to stake key pair, from a list of
-- (payment, staking) key pairs.
mkStakeKeyHashMap :: KeyPairs -> Map (KeyHash 'Staking) (KeyPair 'Staking)
mkStakeKeyHashMap :: KeyPairs -> Map (KeyHash 'Staking) (KeyPair 'Staking)
mkStakeKeyHashMap KeyPairs
keyPairs =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall {a} {kd :: KeyRole}.
(a, KeyPair kd) -> (KeyHash kd, KeyPair kd)
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyPairs
keyPairs)
  where
    f :: (a, KeyPair kd) -> (KeyHash kd, KeyPair kd)
f (a
_payK, KeyPair kd
stakeK) = ((forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey) KeyPair kd
stakeK, KeyPair kd
stakeK)

-- | Generate a mapping from payment key hash to keypair
-- from a list of (payment, staking) key pairs.
mkPayKeyHashMap ::
  KeyPairs ->
  Map (KeyHash 'Payment) (KeyPair 'Payment)
mkPayKeyHashMap :: KeyPairs -> Map (KeyHash 'Payment) (KeyPair 'Payment)
mkPayKeyHashMap KeyPairs
keyPairs =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall {kd :: KeyRole} {b}.
(KeyPair kd, b) -> (KeyHash kd, KeyPair kd)
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyPairs
keyPairs)
  where
    f :: (KeyPair kd, b) -> (KeyHash kd, KeyPair kd)
f (KeyPair kd
payK, b
_stakeK) = ((forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey) KeyPair kd
payK, KeyPair kd
payK)

-- | Find first matching key pair for a credential. Returns the matching key pair
-- where the first element of the pair matched the hash in 'addr'.
findPayKeyPairCred ::
  forall kr.
  Credential kr ->
  Map (KeyHash kr) (KeyPair kr) ->
  KeyPair kr
findPayKeyPairCred :: forall (kr :: KeyRole).
Credential kr -> Map (KeyHash kr) (KeyPair kr) -> KeyPair kr
findPayKeyPairCred (KeyHashObj KeyHash kr
addr) Map (KeyHash kr) (KeyPair kr)
keyHashMap =
  forall a. a -> Maybe a -> a
fromMaybe
    (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"findPayKeyPairCred: could not find a match for the given credential: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show KeyHash kr
addr)
    (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash kr
addr Map (KeyHash kr) (KeyPair kr)
keyHashMap)
findPayKeyPairCred Credential kr
_ Map (KeyHash kr) (KeyPair kr)
_ =
  forall a. HasCallStack => String -> a
error String
"findPayKeyPairCred: expects only KeyHashObj"

-- | Find first matching key pair for address. Returns the matching key pair
-- where the first element of the pair matched the hash in 'addr'.
findPayKeyPairAddr ::
  Addr ->
  Map (KeyHash 'Payment) (KeyPair 'Payment) ->
  KeyPair 'Payment
findPayKeyPairAddr :: Addr
-> Map (KeyHash 'Payment) (KeyPair 'Payment) -> KeyPair 'Payment
findPayKeyPairAddr Addr
a Map (KeyHash 'Payment) (KeyPair 'Payment)
keyHashMap =
  case Addr
a of
    Addr Network
_ PaymentCredential
addr (StakeRefBase StakeCredential
_) -> forall (kr :: KeyRole).
Credential kr -> Map (KeyHash kr) (KeyPair kr) -> KeyPair kr
findPayKeyPairCred PaymentCredential
addr Map (KeyHash 'Payment) (KeyPair 'Payment)
keyHashMap
    Addr Network
_ PaymentCredential
addr (StakeRefPtr Ptr
_) -> forall (kr :: KeyRole).
Credential kr -> Map (KeyHash kr) (KeyPair kr) -> KeyPair kr
findPayKeyPairCred PaymentCredential
addr Map (KeyHash 'Payment) (KeyPair 'Payment)
keyHashMap
    Addr
_ ->
      forall a. HasCallStack => String -> a
error String
"findPayKeyPairAddr: expects only Base or Ptr addresses"

-- | Find matching multisig scripts for a credential.
findPayScriptFromCred ::
  forall era.
  Credential 'Witness ->
  Map ScriptHash (Script era, Script era) ->
  (Script era, Script era)
findPayScriptFromCred :: forall era.
Credential 'Witness
-> Map ScriptHash (Script era, Script era)
-> (Script era, Script era)
findPayScriptFromCred (ScriptHashObj ScriptHash
scriptHash) Map ScriptHash (Script era, Script era)
scriptsByPayHash =
  forall a. a -> Maybe a -> a
fromMaybe
    (forall a. HasCallStack => String -> a
error String
"findPayScript: could not find matching script for given credential")
    (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash
scriptHash Map ScriptHash (Script era, Script era)
scriptsByPayHash)
findPayScriptFromCred Credential 'Witness
_ Map ScriptHash (Script era, Script era)
_ =
  forall a. HasCallStack => String -> a
error String
"findPayScriptFromCred: expects only ScriptHashObj"

-- | Find first matching script for a credential.
findStakeScriptFromCred ::
  Credential 'Witness ->
  Map ScriptHash (Script era, Script era) ->
  (Script era, Script era)
findStakeScriptFromCred :: forall era.
Credential 'Witness
-> Map ScriptHash (Script era, Script era)
-> (Script era, Script era)
findStakeScriptFromCred (ScriptHashObj ScriptHash
scriptHash) Map ScriptHash (Script era, Script era)
scriptsByStakeHash =
  forall a. a -> Maybe a -> a
fromMaybe
    (forall a. HasCallStack => String -> a
error String
"findStakeScriptFromCred: could not find matching script for given credential")
    (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash
scriptHash Map ScriptHash (Script era, Script era)
scriptsByStakeHash)
findStakeScriptFromCred Credential 'Witness
_ Map ScriptHash (Script era, Script era)
_ =
  forall a. HasCallStack => String -> a
error String
"findStakeScriptFromCred: expects only ScriptHashObj"

-- | Find first matching multisig script for an address.
findPayScriptFromAddr ::
  forall era.
  Addr ->
  Map ScriptHash (Script era, Script era) ->
  (Script era, Script era)
findPayScriptFromAddr :: forall era.
Addr
-> Map ScriptHash (Script era, Script era)
-> (Script era, Script era)
findPayScriptFromAddr (Addr Network
_ PaymentCredential
scriptHash (StakeRefBase StakeCredential
_)) Map ScriptHash (Script era, Script era)
scriptsByPayHash =
  forall era.
Credential 'Witness
-> Map ScriptHash (Script era, Script era)
-> (Script era, Script era)
findPayScriptFromCred @era (forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness PaymentCredential
scriptHash) Map ScriptHash (Script era, Script era)
scriptsByPayHash
findPayScriptFromAddr (Addr Network
_ PaymentCredential
scriptHash (StakeRefPtr Ptr
_)) Map ScriptHash (Script era, Script era)
scriptsByPayHash =
  forall era.
Credential 'Witness
-> Map ScriptHash (Script era, Script era)
-> (Script era, Script era)
findPayScriptFromCred @era (forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness PaymentCredential
scriptHash) Map ScriptHash (Script era, Script era)
scriptsByPayHash
findPayScriptFromAddr Addr
_ Map ScriptHash (Script era, Script era)
_ =
  forall a. HasCallStack => String -> a
error String
"findPayScriptFromAddr: expects only base and pointer script addresses"

-- | Select one random verification staking key from list of pairs of KeyPair.
pickStakeKey :: KeyPairs -> Gen (VKey 'Staking)
pickStakeKey :: KeyPairs -> Gen (VKey 'Staking)
pickStakeKey KeyPairs
keys = forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HasCallStack => [a] -> Gen a
QC.elements KeyPairs
keys

-- | Generates a list of coins for the given 'Addr' and produced a 'TxOut' for each 'Addr'
--
-- Note: we need to keep the initial utxo coin sizes large enough so that
-- when we simulate sequences of transactions, we have enough funds available
-- to include certificates that require deposits.
genTxOut ::
  forall era.
  EraTxOut era =>
  Gen (Value era) ->
  [Addr] ->
  Gen [TxOut era]
genTxOut :: forall era.
EraTxOut era =>
Gen (Value era) -> [Addr] -> Gen [TxOut era]
genTxOut Gen (Value era)
genEraVal [Addr]
addrs = do
  [Value era]
values <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Addr]
addrs) Gen (Value era)
genEraVal
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. [a] -> [b] -> [(a, b)]
zip [Addr]
addrs [Value era]
values)

-- | Generates a list of 'Coin' values of length between 'lower' and 'upper'
-- and with values between 'minCoin' and 'maxCoin'.
genCoinList :: Integer -> Integer -> Int -> Gen [Coin]
genCoinList :: Integer -> Integer -> Int -> Gen [Coin]
genCoinList Integer
minCoin Integer
maxCoin Int
len = do
  forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
len forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Gen Coin
genCoin Integer
minCoin Integer
maxCoin

-- | Generate values the given distribution in 90% of the cases, and values at
-- the bounds of the range in 10% of the cases.
--
-- This can be used to generate enough extreme values. The exponential and
-- linear distributions provided by @hedgehog@ will generate a small percentage
-- of these (0-1%).
increasingProbabilityAt ::
  Gen a ->
  (a, a) ->
  Gen a
increasingProbabilityAt :: forall a. Gen a -> (a, a) -> Gen a
increasingProbabilityAt Gen a
gen (a
lower, a
upper) =
  forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
    [ (Int
5, forall (f :: * -> *) a. Applicative f => a -> f a
pure a
lower)
    , (Int
90, Gen a
gen)
    , (Int
5, forall (f :: * -> *) a. Applicative f => a -> f a
pure a
upper)
    ]

-- | Takes a sequence of KES hot keys and checks to see whether there is one whose
-- range contains the current KES period. If so, return its index in the list of
-- hot keys.
getKESPeriodRenewalNo :: AllIssuerKeys h r -> KESPeriod -> Integer
getKESPeriodRenewalNo :: forall h (r :: KeyRole). AllIssuerKeys h r -> KESPeriod -> Integer
getKESPeriodRenewalNo AllIssuerKeys h r
keys (KESPeriod Word
kp) =
  forall {t} {b}. Num t => [(KESPeriod, b)] -> t -> Word -> t
go (forall a. NonEmpty a -> [a]
NE.toList (forall c (r :: KeyRole).
AllIssuerKeys c r -> NonEmpty (KESPeriod, KESKeyPair c)
aikHot AllIssuerKeys h r
keys)) Integer
0 Word
kp
  where
    go :: [(KESPeriod, b)] -> t -> Word -> t
go [] t
_ Word
_ = forall a. HasCallStack => String -> a
error String
"did not find enough KES renewals"
    go ((KESPeriod Word
p, b
_) : [(KESPeriod, b)]
rest) t
n Word
k =
      if Word
p forall a. Ord a => a -> a -> Bool
<= Word
k Bool -> Bool -> Bool
&& Word
k forall a. Ord a => a -> a -> Bool
< Word
p forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
maxKESIterations
        then t
n
        else [(KESPeriod, b)] -> t -> Word -> t
go [(KESPeriod, b)]
rest (t
n forall a. Num a => a -> a -> a
+ t
1) Word
k

-- | True if the given slot is within the last `2 * stabilityWindow`
-- slots of the current epoch.
tooLateInEpoch :: SlotNo -> Bool
tooLateInEpoch :: SlotNo -> Bool
tooLateInEpoch SlotNo
s = forall a. ShelleyBase a -> a
runShelleyBase forall a b. (a -> b) -> a -> b
$ do
  EpochInfo Identity
ei <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> EpochInfo Identity
epochInfoPure
  let firstSlotNo :: SlotNo
firstSlotNo = HasCallStack => EpochInfo Identity -> EpochNo -> SlotNo
epochInfoFirst EpochInfo Identity
ei (SlotNo -> EpochNo
epochFromSlotNo SlotNo
s forall a. Num a => a -> a -> a
+ EpochNo
1)
  Word64
stabilityWindow <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> Word64
stabilityWindow

  forall (m :: * -> *) a. Monad m => a -> m a
return (SlotNo
s forall a. Ord a => a -> a -> Bool
>= SlotNo
firstSlotNo SlotNo -> Duration -> SlotNo
*- Word64 -> Duration
Duration (Word64
2 forall a. Num a => a -> a -> a
* Word64
stabilityWindow))

-- | Account with empty treasury
genesisAccountState :: AccountState
genesisAccountState :: AccountState
genesisAccountState =
  AccountState
    { asTreasury :: Coin
asTreasury = Integer -> Coin
Coin Integer
0
    , asReserves :: Coin
asReserves = Coin
maxLLSupply
    }

-- | Creates the UTxO for a new ledger with the specified
-- genesis TxId and transaction outputs.
genesisCoins ::
  TxId ->
  [TxOut era] ->
  UTxO era
genesisCoins :: forall era. TxId -> [TxOut era] -> UTxO era
genesisCoins TxId
genesisTxId [TxOut era]
outs =
  forall era. Map TxIn (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TxId -> TxIx -> TxIn
TxIn TxId
genesisTxId TxIx
idx, TxOut era
out) | (TxIx
idx, TxOut era
out) <- forall a b. [a] -> [b] -> [(a, b)]
zip [forall a. Bounded a => a
minBound ..] [TxOut era]
outs]

-- ==================================================================
-- Operations on GenEnv that deal with ScriptSpace

hashData :: PV1.Data -> DataHash
hashData :: Data -> DataHash
hashData Data
x = forall i. Hash HASH i -> SafeHash i
unsafeMakeSafeHash (forall h a b. Hash h a -> Hash h b
Hash.castHash (forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
Hash.hashWith (ByteString -> ByteString
toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialise a => a -> ByteString
serialise) Data
x))

{-
-- | Choose one of the preallocated PlutusScripts, and return it and its Hash
genPlutus :: forall era. GenEnv era -> Gen (Script era, ScriptHash (Crypto era), TwoPhaseInfo era)
genPlutus (GenEnv _ (ScriptSpace scripts _) _) = gettriple <$> oneof (pure <$> scripts)
  where gettriple (info@(TwoPhaseInfo script hash _data _rdmr)) = (script,hash,info)
-}

-- | Find the preallocated Script from its Hash.
findPlutus ::
  forall era.
  GenEnv era ->
  ScriptHash ->
  (Script era, StrictMaybe DataHash)
findPlutus :: forall era.
GenEnv era -> ScriptHash -> (Script era, StrictMaybe DataHash)
findPlutus (GenEnv KeySpace era
keyspace (ScriptSpace [TwoPhase3ArgInfo era]
_ [TwoPhase2ArgInfo era]
_ Map ScriptHash (TwoPhase3ArgInfo era)
mp3 Map ScriptHash (TwoPhase2ArgInfo era)
mp2) Constants
_) ScriptHash
hsh =
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash
hsh Map ScriptHash (TwoPhase3ArgInfo era)
mp3 of
    Just TwoPhase3ArgInfo era
info3 -> (forall era. TwoPhase3ArgInfo era -> Script era
getScript3 TwoPhase3ArgInfo era
info3, forall a. a -> StrictMaybe a
SJust (Data -> DataHash
hashData (forall era. TwoPhase3ArgInfo era -> Data
getData3 TwoPhase3ArgInfo era
info3)))
    Maybe (TwoPhase3ArgInfo era)
Nothing ->
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash
hsh Map ScriptHash (TwoPhase2ArgInfo era)
mp2 of
        Just TwoPhase2ArgInfo era
info2 -> (forall era. TwoPhase2ArgInfo era -> Script era
getScript2 TwoPhase2ArgInfo era
info2, forall a. StrictMaybe a
SNothing)
        Maybe (TwoPhase2ArgInfo era)
Nothing -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash
hsh (forall era. KeySpace era -> Map ScriptHash (Script era, Script era)
ksIndexedPayScripts KeySpace era
keyspace) of
          Just (Script era
pay, Script era
_ssStake) -> (Script era
pay, forall a. StrictMaybe a
SNothing)
          Maybe (Script era, Script era)
Nothing ->
            case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash
hsh (forall era. KeySpace era -> Map ScriptHash (Script era, Script era)
ksIndexedStakeScripts KeySpace era
keyspace) of
              Just (Script era
_pay, Script era
stake) -> (Script era
stake, forall a. StrictMaybe a
SNothing)
              Maybe (Script era, Script era)
Nothing -> forall a. HasCallStack => String -> a
error (String
"Can't find a Script for the hash: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ScriptHash
hsh)