{-# 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,
  mkCredential,
  mkBlock,
  mkBlockFakeVRF,
  mkOCert,
  getKESPeriodRenewalNo,
  tooLateInEpoch,
  RawSeed (..),
  mkKeyPair,
  mkKeyPairs,
  mkGenKey,
  genesisChainAccountState,
  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.State
import Cardano.Ledger.Shelley.TxWits (ShelleyTxWits)
import Cardano.Ledger.Slot (
  Duration (..),
  SlotNo (..),
  epochInfoFirst,
  (*-),
 )
import Cardano.Ledger.TxIn (TxId, TxIn (TxIn))
import Cardano.Protocol.Crypto (Crypto)
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, mkCredential, vKey)
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 c era = GenEnv
  { forall c era. GenEnv c era -> KeySpace c era
geKeySpace :: KeySpace c era
  , forall c era. GenEnv c era -> ScriptSpace era
geScriptSpapce :: ScriptSpace era
  , forall c era. GenEnv c 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 c era = KeySpace_
  { forall c era.
KeySpace c era
-> [(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
ksCoreNodes :: [(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
  , forall c era. KeySpace c era -> [AllIssuerKeys c 'GenesisDelegate]
ksGenesisDelegates :: [AllIssuerKeys c 'GenesisDelegate]
  -- ^ Bag of keys to be used for future genesis delegates
  , forall c era. KeySpace c era -> [AllIssuerKeys c 'StakePool]
ksStakePools :: [AllIssuerKeys c 'StakePool]
  -- ^ Bag of keys to be used for future stake pools
  , forall c era. KeySpace c era -> KeyPairs
ksKeyPairs :: KeyPairs
  -- ^ Bag of keys to be used for future payment/staking addresses
  , forall c era. KeySpace c era -> [(Script era, Script era)]
ksMSigScripts :: [(Script era, Script era)]
  , forall c era.
KeySpace c era -> Map (KeyHash 'Payment) (KeyPair 'Payment)
ksIndexedPaymentKeys :: Map (KeyHash 'Payment) (KeyPair 'Payment)
  -- ^ Index over the payment keys in 'ksKeyPairs'
  , forall c era.
KeySpace c era -> Map (KeyHash 'Staking) (KeyPair 'Staking)
ksIndexedStakingKeys :: Map (KeyHash 'Staking) (KeyPair 'Staking)
  -- ^ Index over the staking keys in 'ksKeyPairs'
  , forall c era.
KeySpace c era
-> Map
     (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
ksIndexedGenDelegates ::
      Map (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
  -- ^ Index over the cold key hashes in Genesis Delegates
  , forall c era.
KeySpace c era -> Map ScriptHash (Script era, Script era)
ksIndexedPayScripts :: Map ScriptHash (Script era, Script era)
  -- ^ Index over the pay script hashes in Script pairs
  , forall c era.
KeySpace c 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), Crypto c) => Show (KeySpace c era)

pattern KeySpace ::
  forall c era.
  ScriptClass era =>
  [(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)] ->
  [AllIssuerKeys c 'GenesisDelegate] ->
  [AllIssuerKeys c 'StakePool] ->
  KeyPairs ->
  [(Script era, Script era)] ->
  KeySpace c era
pattern $mKeySpace :: forall {r} {c} {era}.
ScriptClass era =>
KeySpace c era
-> ([(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
    -> [AllIssuerKeys c 'GenesisDelegate]
    -> [AllIssuerKeys c 'StakePool]
    -> KeyPairs
    -> [(Script era, Script era)]
    -> r)
-> ((# #) -> r)
-> r
$bKeySpace :: forall c era.
ScriptClass era =>
[(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
-> [AllIssuerKeys c 'GenesisDelegate]
-> [AllIssuerKeys c 'StakePool]
-> KeyPairs
-> [(Script era, Script era)]
-> KeySpace c era
KeySpace
  ksCoreNodes
  ksGenesisDelegates
  ksStakePools
  ksKeyPairs
  ksMSigScripts <-
  KeySpace_
    { ksCoreNodes
    , ksGenesisDelegates
    , ksStakePools
    , ksKeyPairs
    , ksMSigScripts
    }
  where
    KeySpace [(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
ksCoreNodes [AllIssuerKeys c 'GenesisDelegate]
ksGenesisDelegates [AllIssuerKeys c 'StakePool]
ksStakePools KeyPairs
ksKeyPairs [(Script era, Script era)]
ksMSigScripts =
      KeySpace_
        { [(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
ksCoreNodes :: [(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
ksCoreNodes :: [(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
ksCoreNodes
        , [AllIssuerKeys c 'GenesisDelegate]
ksGenesisDelegates :: [AllIssuerKeys c 'GenesisDelegate]
ksGenesisDelegates :: [AllIssuerKeys c 'GenesisDelegate]
ksGenesisDelegates
        , [AllIssuerKeys c 'StakePool]
ksStakePools :: [AllIssuerKeys c 'StakePool]
ksStakePools :: [AllIssuerKeys c '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 c 'GenesisDelegate)
ksIndexedGenDelegates = [(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
-> [AllIssuerKeys c 'GenesisDelegate]
-> Map
     (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
forall c.
[(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
-> [AllIssuerKeys c 'GenesisDelegate]
-> Map
     (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
mkGenesisDelegatesHashMap [(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
ksCoreNodes [AllIssuerKeys c '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 (Integer -> Coin) -> Gen Integer -> Gen 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 = Gen Bool
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 = (Integer, Integer) -> Gen Integer
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 = Integer -> Natural
forall a. Num a => Integer -> a
fromInteger (Integer -> Natural) -> Gen Integer -> Gen Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
QC.choose (Integer
lower', Integer
upper')
  where
    lower' :: Integer
lower' = Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
lower
    upper' :: Integer
upper' = Natural -> Integer
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 =
  Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    (Natural -> Word64) -> Gen Natural -> Gen Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> Natural -> Gen Natural
genNatural (Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
lower) (Word64 -> Natural
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 c, AllIssuerKeys c 'GenesisDelegate)]
-> [AllIssuerKeys c 'GenesisDelegate]
-> Map
     (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
mkGenesisDelegatesHashMap [(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
coreNodes [AllIssuerKeys c 'GenesisDelegate]
genesisDelegates =
  [(KeyHash 'GenesisDelegate, AllIssuerKeys c 'GenesisDelegate)]
-> Map
     (KeyHash 'GenesisDelegate) (AllIssuerKeys c 'GenesisDelegate)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (AllIssuerKeys c 'GenesisDelegate
-> (KeyHash 'GenesisDelegate, AllIssuerKeys c 'GenesisDelegate)
forall {c} {kd :: KeyRole}.
AllIssuerKeys c kd -> (KeyHash kd, AllIssuerKeys c kd)
f (AllIssuerKeys c 'GenesisDelegate
 -> (KeyHash 'GenesisDelegate, AllIssuerKeys c 'GenesisDelegate))
-> [AllIssuerKeys c 'GenesisDelegate]
-> [(KeyHash 'GenesisDelegate, AllIssuerKeys c 'GenesisDelegate)]
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 = (VKey kd -> KeyHash kd
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey kd -> KeyHash kd)
-> (KeyPair kd -> VKey kd) -> KeyPair kd -> KeyHash kd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair kd -> VKey kd
forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey (KeyPair kd -> KeyHash kd) -> KeyPair kd -> KeyHash kd
forall a b. (a -> b) -> a -> b
$ AllIssuerKeys c kd -> KeyPair kd
forall c (r :: KeyRole). AllIssuerKeys c r -> KeyPair r
aikCold AllIssuerKeys c kd
issuerKeys, AllIssuerKeys c kd
issuerKeys)
    allDelegateKeys :: [AllIssuerKeys c 'GenesisDelegate]
allDelegateKeys = ((GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)
-> AllIssuerKeys c 'GenesisDelegate
forall a b. (a, b) -> b
snd ((GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)
 -> AllIssuerKeys c 'GenesisDelegate)
-> [(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
-> [AllIssuerKeys c 'GenesisDelegate]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
coreNodes) [AllIssuerKeys c 'GenesisDelegate]
-> [AllIssuerKeys c 'GenesisDelegate]
-> [AllIssuerKeys c 'GenesisDelegate]
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 =
  [(KeyHash 'Staking, KeyPair 'Staking)]
-> Map (KeyHash 'Staking) (KeyPair 'Staking)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((KeyPair 'Payment, KeyPair 'Staking)
-> (KeyHash 'Staking, KeyPair 'Staking)
forall {a} {kd :: KeyRole}.
(a, KeyPair kd) -> (KeyHash kd, KeyPair kd)
f ((KeyPair 'Payment, KeyPair 'Staking)
 -> (KeyHash 'Staking, KeyPair 'Staking))
-> KeyPairs -> [(KeyHash 'Staking, KeyPair 'Staking)]
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) = ((VKey kd -> KeyHash kd
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey kd -> KeyHash kd)
-> (KeyPair kd -> VKey kd) -> KeyPair kd -> KeyHash kd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair kd -> VKey kd
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 =
  [(KeyHash 'Payment, KeyPair 'Payment)]
-> Map (KeyHash 'Payment) (KeyPair 'Payment)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((KeyPair 'Payment, KeyPair 'Staking)
-> (KeyHash 'Payment, KeyPair 'Payment)
forall {kd :: KeyRole} {b}.
(KeyPair kd, b) -> (KeyHash kd, KeyPair kd)
f ((KeyPair 'Payment, KeyPair 'Staking)
 -> (KeyHash 'Payment, KeyPair 'Payment))
-> KeyPairs -> [(KeyHash 'Payment, KeyPair 'Payment)]
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) = ((VKey kd -> KeyHash kd
forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey (VKey kd -> KeyHash kd)
-> (KeyPair kd -> VKey kd) -> KeyPair kd -> KeyHash kd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyPair kd -> VKey kd
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 =
  KeyPair kr -> Maybe (KeyPair kr) -> KeyPair kr
forall a. a -> Maybe a -> a
fromMaybe
    (String -> KeyPair kr
forall a. HasCallStack => String -> a
error (String -> KeyPair kr) -> String -> KeyPair kr
forall a b. (a -> b) -> a -> b
$ String
"findPayKeyPairCred: could not find a match for the given credential: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> KeyHash kr -> String
forall a. Show a => a -> String
show KeyHash kr
addr)
    (KeyHash kr -> Map (KeyHash kr) (KeyPair kr) -> Maybe (KeyPair kr)
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)
_ =
  String -> 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
_) -> PaymentCredential
-> Map (KeyHash 'Payment) (KeyPair 'Payment) -> KeyPair 'Payment
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
_) -> PaymentCredential
-> Map (KeyHash 'Payment) (KeyPair 'Payment) -> KeyPair 'Payment
forall (kr :: KeyRole).
Credential kr -> Map (KeyHash kr) (KeyPair kr) -> KeyPair kr
findPayKeyPairCred PaymentCredential
addr Map (KeyHash 'Payment) (KeyPair 'Payment)
keyHashMap
    Addr
_ ->
      String -> KeyPair 'Payment
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 =
  (Script era, Script era)
-> Maybe (Script era, Script era) -> (Script era, Script era)
forall a. a -> Maybe a -> a
fromMaybe
    (String -> (Script era, Script era)
forall a. HasCallStack => String -> a
error String
"findPayScript: could not find matching script for given credential")
    (ScriptHash
-> Map ScriptHash (Script era, Script era)
-> Maybe (Script era, Script era)
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)
_ =
  String -> (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 =
  (Script era, Script era)
-> Maybe (Script era, Script era) -> (Script era, Script era)
forall a. a -> Maybe a -> a
fromMaybe
    (String -> (Script era, Script era)
forall a. HasCallStack => String -> a
error String
"findStakeScriptFromCred: could not find matching script for given credential")
    (ScriptHash
-> Map ScriptHash (Script era, Script era)
-> Maybe (Script era, Script era)
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)
_ =
  String -> (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 (PaymentCredential -> Credential 'Witness
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 (PaymentCredential -> Credential 'Witness
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)
_ =
  String -> (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 = KeyPair 'Staking -> VKey 'Staking
forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey (KeyPair 'Staking -> VKey 'Staking)
-> ((KeyPair 'Payment, KeyPair 'Staking) -> KeyPair 'Staking)
-> (KeyPair 'Payment, KeyPair 'Staking)
-> VKey 'Staking
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyPair 'Payment, KeyPair 'Staking) -> KeyPair 'Staking
forall a b. (a, b) -> b
snd ((KeyPair 'Payment, KeyPair 'Staking) -> VKey 'Staking)
-> Gen (KeyPair 'Payment, KeyPair 'Staking) -> Gen (VKey 'Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyPairs -> Gen (KeyPair 'Payment, KeyPair 'Staking)
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 <- Int -> Gen (Value era) -> Gen [Value era]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([Addr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Addr]
addrs) Gen (Value era)
genEraVal
  [TxOut era] -> Gen [TxOut era]
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Addr -> Value era -> TxOut era) -> (Addr, Value era) -> TxOut era
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut ((Addr, Value era) -> TxOut era)
-> [(Addr, Value era)] -> [TxOut era]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Addr] -> [Value era] -> [(Addr, Value era)]
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
  Int -> Gen Coin -> Gen [Coin]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
len (Gen Coin -> Gen [Coin]) -> Gen Coin -> Gen [Coin]
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) =
  [(Int, Gen a)] -> Gen a
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
    [ (Int
5, a -> Gen a
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
lower)
    , (Int
90, Gen a
gen)
    , (Int
5, a -> Gen a
forall a. a -> Gen a
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) =
  [(KESPeriod, KESKeyPair h)] -> Integer -> Word -> Integer
forall {t} {b}. Num t => [(KESPeriod, b)] -> t -> Word -> t
go (NonEmpty (KESPeriod, KESKeyPair h) -> [(KESPeriod, KESKeyPair h)]
forall a. NonEmpty a -> [a]
NE.toList (AllIssuerKeys h r -> NonEmpty (KESPeriod, KESKeyPair h)
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
_ = String -> t
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 Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
k Bool -> Bool -> Bool
&& Word
k Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
< Word
p Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word64 -> Word
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 t -> t -> t
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 = ShelleyBase Bool -> Bool
forall a. ShelleyBase a -> a
runShelleyBase (ShelleyBase Bool -> Bool) -> ShelleyBase Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
  EpochInfo Identity
ei <- (Globals -> EpochInfo Identity)
-> ReaderT Globals Identity (EpochInfo Identity)
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
EpochInfo Identity -> EpochNo -> SlotNo
epochInfoFirst EpochInfo Identity
ei (SlotNo -> EpochNo
epochFromSlotNo SlotNo
s EpochNo -> EpochNo -> EpochNo
forall a. Num a => a -> a -> a
+ EpochNo
1)
  Word64
stabilityWindow <- (Globals -> Word64) -> ReaderT Globals Identity Word64
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> Word64
stabilityWindow

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

-- | Account with empty treasury
genesisChainAccountState :: ChainAccountState
genesisChainAccountState :: ChainAccountState
genesisChainAccountState =
  ChainAccountState
    { casTreasury :: Coin
casTreasury = Integer -> Coin
Coin Integer
0
    , casReserves :: Coin
casReserves = 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 =
  Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (Map TxIn (TxOut era) -> UTxO era)
-> Map TxIn (TxOut era) -> UTxO era
forall a b. (a -> b) -> a -> b
$
    [(TxIn, TxOut era)] -> Map TxIn (TxOut era)
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) <- [TxIx] -> [TxOut era] -> [(TxIx, TxOut era)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TxIx
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 = Hash HASH EraIndependentData -> DataHash
forall i. Hash HASH i -> SafeHash i
unsafeMakeSafeHash (Hash HASH Data -> Hash HASH EraIndependentData
forall h a b. Hash h a -> Hash h b
Hash.castHash ((Data -> ByteString) -> Data -> Hash HASH Data
forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
Hash.hashWith (ByteString -> ByteString
toStrict (ByteString -> ByteString)
-> (Data -> ByteString) -> Data -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Data -> ByteString
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 c.
  GenEnv c era ->
  ScriptHash ->
  (Script era, StrictMaybe DataHash)
findPlutus :: forall era c.
GenEnv c era -> ScriptHash -> (Script era, StrictMaybe DataHash)
findPlutus (GenEnv KeySpace c era
keyspace (ScriptSpace [TwoPhase3ArgInfo era]
_ [TwoPhase2ArgInfo era]
_ Map ScriptHash (TwoPhase3ArgInfo era)
mp3 Map ScriptHash (TwoPhase2ArgInfo era)
mp2) Constants
_) ScriptHash
hsh =
  case ScriptHash
-> Map ScriptHash (TwoPhase3ArgInfo era)
-> Maybe (TwoPhase3ArgInfo era)
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 -> (TwoPhase3ArgInfo era -> Script era
forall era. TwoPhase3ArgInfo era -> Script era
getScript3 TwoPhase3ArgInfo era
info3, DataHash -> StrictMaybe DataHash
forall a. a -> StrictMaybe a
SJust (Data -> DataHash
hashData (TwoPhase3ArgInfo era -> Data
forall era. TwoPhase3ArgInfo era -> Data
getData3 TwoPhase3ArgInfo era
info3)))
    Maybe (TwoPhase3ArgInfo era)
Nothing ->
      case ScriptHash
-> Map ScriptHash (TwoPhase2ArgInfo era)
-> Maybe (TwoPhase2ArgInfo era)
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 -> (TwoPhase2ArgInfo era -> Script era
forall era. TwoPhase2ArgInfo era -> Script era
getScript2 TwoPhase2ArgInfo era
info2, StrictMaybe DataHash
forall a. StrictMaybe a
SNothing)
        Maybe (TwoPhase2ArgInfo era)
Nothing -> case ScriptHash
-> Map ScriptHash (Script era, Script era)
-> Maybe (Script era, Script era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash
hsh (KeySpace c era -> Map ScriptHash (Script era, Script era)
forall c era.
KeySpace c era -> Map ScriptHash (Script era, Script era)
ksIndexedPayScripts KeySpace c era
keyspace) of
          Just (Script era
pay, Script era
_ssStake) -> (Script era
pay, StrictMaybe DataHash
forall a. StrictMaybe a
SNothing)
          Maybe (Script era, Script era)
Nothing ->
            case ScriptHash
-> Map ScriptHash (Script era, Script era)
-> Maybe (Script era, Script era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash
hsh (KeySpace c era -> Map ScriptHash (Script era, Script era)
forall c era.
KeySpace c era -> Map ScriptHash (Script era, Script era)
ksIndexedStakeScripts KeySpace c era
keyspace) of
              Just (Script era
_pay, Script era
stake) -> (Script era
stake, StrictMaybe DataHash
forall a. StrictMaybe a
SNothing)
              Maybe (Script era, Script era)
Nothing -> String -> (Script era, StrictMaybe DataHash)
forall a. HasCallStack => String -> a
error (String
"Can't find a Script for the hash: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ScriptHash -> String
forall a. Show a => a -> String
show ScriptHash
hsh)