{-# 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,
  unitIntervalToNatural,
  mkBlock,
  mkBlockHeader,
  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 (
  BoundedRational (..),
  Nonce (..),
  ProtVer (..),
  StrictMaybe (..),
  UnitInterval,
  epochInfoPure,
  stabilityWindow,
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core hiding (DataHash)
import Cardano.Ledger.Credential (
  Credential (..),
  pattern KeyHashObj,
  pattern ScriptHashObj,
  pattern StakeRefBase,
  pattern StakeRefPtr,
 )
import Cardano.Ledger.Crypto (Crypto)
import Cardano.Ledger.Keys (
  Hash,
  KeyHash,
  KeyRole (..),
  VKey,
  asWitness,
  hashKey,
 )
import Cardano.Ledger.SafeHash (SafeHash, unsafeMakeSafeHash)
import Cardano.Ledger.Shelley.LedgerState (AccountState (..))
import Cardano.Ledger.Shelley.TxWits (
  ShelleyTxWits,
 )
import Cardano.Ledger.Slot (
  BlockNo (..),
  Duration (..),
  SlotNo (..),
  epochInfoFirst,
  (*-),
 )
import Cardano.Ledger.TxIn (TxId, TxIn (TxIn))
import Cardano.Ledger.UTxO (UTxO (UTxO))
import Cardano.Protocol.TPraos.BHeader (BHeader, HashHeader)
import Cardano.Protocol.TPraos.OCert (KESPeriod (..), OCert)
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.Ratio (denominator, numerator, (%))
import Data.Word (Word32, 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 (Mock)
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 (..),
  mkBHBody,
  mkBHeader,
  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 DataHash c = SafeHash c EraIndependentData

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

data TwoPhase3ArgInfo era = TwoPhase3ArgInfo
  { forall era. TwoPhase3ArgInfo era -> Script era
getScript3 :: Script era
  -- ^ A Plutus Script
  , forall era. TwoPhase3ArgInfo era -> ScriptHash (EraCrypto era)
getHash3 :: ScriptHash (EraCrypto era)
  -- ^ 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 (EraCrypto era)
getHash2 :: ScriptHash (EraCrypto era)
  -- ^ 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 (EraCrypto era)) (TwoPhase3ArgInfo era)
ssHash3 :: Map (ScriptHash (EraCrypto era)) (TwoPhase3ArgInfo era)
  , forall era.
ScriptSpace era
-> Map (ScriptHash (EraCrypto era)) (TwoPhase2ArgInfo era)
ssHash2 :: Map (ScriptHash (EraCrypto era)) (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 (EraCrypto era),
     AllIssuerKeys (EraCrypto era) 'GenesisDelegate)]
ksCoreNodes :: [(GenesisKeyPair (EraCrypto era), AllIssuerKeys (EraCrypto era) 'GenesisDelegate)]
  , forall era.
KeySpace era -> [AllIssuerKeys (EraCrypto era) 'GenesisDelegate]
ksGenesisDelegates :: [AllIssuerKeys (EraCrypto era) 'GenesisDelegate]
  -- ^ Bag of keys to be used for future genesis delegates
  , forall era.
KeySpace era -> [AllIssuerKeys (EraCrypto era) 'StakePool]
ksStakePools :: [AllIssuerKeys (EraCrypto era) 'StakePool]
  -- ^ Bag of keys to be used for future stake pools
  , forall era. KeySpace era -> KeyPairs (EraCrypto era)
ksKeyPairs :: KeyPairs (EraCrypto era)
  -- ^ 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 (EraCrypto era))
     (KeyPair 'Payment (EraCrypto era))
ksIndexedPaymentKeys :: Map (KeyHash 'Payment (EraCrypto era)) (KeyPair 'Payment (EraCrypto era))
  -- ^ Index over the payment keys in 'ksKeyPairs'
  , forall era.
KeySpace era
-> Map
     (KeyHash 'Staking (EraCrypto era))
     (KeyPair 'Staking (EraCrypto era))
ksIndexedStakingKeys :: Map (KeyHash 'Staking (EraCrypto era)) (KeyPair 'Staking (EraCrypto era))
  -- ^ Index over the staking keys in 'ksKeyPairs'
  , forall era.
KeySpace era
-> Map
     (KeyHash 'GenesisDelegate (EraCrypto era))
     (AllIssuerKeys (EraCrypto era) 'GenesisDelegate)
ksIndexedGenDelegates ::
      Map (KeyHash 'GenesisDelegate (EraCrypto era)) (AllIssuerKeys (EraCrypto era) 'GenesisDelegate)
  -- ^ Index over the cold key hashes in Genesis Delegates
  , forall era.
KeySpace era
-> Map (ScriptHash (EraCrypto era)) (Script era, Script era)
ksIndexedPayScripts :: Map (ScriptHash (EraCrypto era)) (Script era, Script era)
  -- ^ Index over the pay script hashes in Script pairs
  , forall era.
KeySpace era
-> Map (ScriptHash (EraCrypto era)) (Script era, Script era)
ksIndexedStakeScripts :: Map (ScriptHash (EraCrypto era)) (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 (EraCrypto era), AllIssuerKeys (EraCrypto era) 'GenesisDelegate)] ->
  [AllIssuerKeys (EraCrypto era) 'GenesisDelegate] ->
  [AllIssuerKeys (EraCrypto era) 'StakePool] ->
  KeyPairs (EraCrypto era) ->
  [(Script era, Script era)] ->
  KeySpace era
pattern $bKeySpace :: forall era.
ScriptClass era =>
[(GenesisKeyPair (EraCrypto era),
  AllIssuerKeys (EraCrypto era) 'GenesisDelegate)]
-> [AllIssuerKeys (EraCrypto era) 'GenesisDelegate]
-> [AllIssuerKeys (EraCrypto era) 'StakePool]
-> KeyPairs (EraCrypto era)
-> [(Script era, Script era)]
-> KeySpace era
$mKeySpace :: forall {r} {era}.
ScriptClass era =>
KeySpace era
-> ([(GenesisKeyPair (EraCrypto era),
      AllIssuerKeys (EraCrypto era) 'GenesisDelegate)]
    -> [AllIssuerKeys (EraCrypto era) 'GenesisDelegate]
    -> [AllIssuerKeys (EraCrypto era) 'StakePool]
    -> KeyPairs (EraCrypto era)
    -> [(Script era, Script era)]
    -> r)
-> ((# #) -> r)
-> r
KeySpace
  ksCoreNodes
  ksGenesisDelegates
  ksStakePools
  ksKeyPairs
  ksMSigScripts <-
  KeySpace_
    { ksCoreNodes
    , ksGenesisDelegates
    , ksStakePools
    , ksKeyPairs
    , ksMSigScripts
    }
  where
    KeySpace [(GenesisKeyPair (EraCrypto era),
  AllIssuerKeys (EraCrypto era) 'GenesisDelegate)]
ksCoreNodes [AllIssuerKeys (EraCrypto era) 'GenesisDelegate]
ksGenesisDelegates [AllIssuerKeys (EraCrypto era) 'StakePool]
ksStakePools KeyPairs (EraCrypto era)
ksKeyPairs [(Script era, Script era)]
ksMSigScripts =
      KeySpace_
        { [(GenesisKeyPair (EraCrypto era),
  AllIssuerKeys (EraCrypto era) 'GenesisDelegate)]
ksCoreNodes :: [(GenesisKeyPair (EraCrypto era),
  AllIssuerKeys (EraCrypto era) 'GenesisDelegate)]
ksCoreNodes :: [(GenesisKeyPair (EraCrypto era),
  AllIssuerKeys (EraCrypto era) 'GenesisDelegate)]
ksCoreNodes
        , [AllIssuerKeys (EraCrypto era) 'GenesisDelegate]
ksGenesisDelegates :: [AllIssuerKeys (EraCrypto era) 'GenesisDelegate]
ksGenesisDelegates :: [AllIssuerKeys (EraCrypto era) 'GenesisDelegate]
ksGenesisDelegates
        , [AllIssuerKeys (EraCrypto era) 'StakePool]
ksStakePools :: [AllIssuerKeys (EraCrypto era) 'StakePool]
ksStakePools :: [AllIssuerKeys (EraCrypto era) 'StakePool]
ksStakePools
        , KeyPairs (EraCrypto era)
ksKeyPairs :: KeyPairs (EraCrypto era)
ksKeyPairs :: KeyPairs (EraCrypto era)
ksKeyPairs
        , ksIndexedPaymentKeys :: Map
  (KeyHash 'Payment (EraCrypto era))
  (KeyPair 'Payment (EraCrypto era))
ksIndexedPaymentKeys = forall c.
Crypto c =>
KeyPairs c -> Map (KeyHash 'Payment c) (KeyPair 'Payment c)
mkPayKeyHashMap KeyPairs (EraCrypto era)
ksKeyPairs
        , ksIndexedStakingKeys :: Map
  (KeyHash 'Staking (EraCrypto era))
  (KeyPair 'Staking (EraCrypto era))
ksIndexedStakingKeys = forall c.
Crypto c =>
KeyPairs c -> Map (KeyHash 'Staking c) (KeyPair 'Staking c)
mkStakeKeyHashMap KeyPairs (EraCrypto era)
ksKeyPairs
        , ksIndexedGenDelegates :: Map
  (KeyHash 'GenesisDelegate (EraCrypto era))
  (AllIssuerKeys (EraCrypto era) 'GenesisDelegate)
ksIndexedGenDelegates = forall c.
Crypto c =>
[(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
-> [AllIssuerKeys c 'GenesisDelegate]
-> Map
     (KeyHash 'GenesisDelegate c) (AllIssuerKeys c 'GenesisDelegate)
mkGenesisDelegatesHashMap [(GenesisKeyPair (EraCrypto era),
  AllIssuerKeys (EraCrypto era) 'GenesisDelegate)]
ksCoreNodes [AllIssuerKeys (EraCrypto era) 'GenesisDelegate]
ksGenesisDelegates
        , ksIndexedPayScripts :: Map (ScriptHash (EraCrypto era)) (Script era, Script era)
ksIndexedPayScripts = forall era.
ScriptClass era =>
[(Script era, Script era)]
-> Map (ScriptHash (EraCrypto era)) (Script era, Script era)
mkPayScriptHashMap @era [(Script era, Script era)]
ksMSigScripts
        , ksIndexedStakeScripts :: Map (ScriptHash (EraCrypto era)) (Script era, Script era)
ksIndexedStakeScripts = forall era.
ScriptClass era =>
[(Script era, Script era)]
-> Map (ScriptHash (EraCrypto era)) (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 ::
  Crypto c =>
  [(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)] ->
  [AllIssuerKeys c 'GenesisDelegate] ->
  Map (KeyHash 'GenesisDelegate c) (AllIssuerKeys c 'GenesisDelegate)
mkGenesisDelegatesHashMap :: forall c.
Crypto c =>
[(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
-> [AllIssuerKeys c 'GenesisDelegate]
-> Map
     (KeyHash 'GenesisDelegate c) (AllIssuerKeys c 'GenesisDelegate)
mkGenesisDelegatesHashMap [(GenesisKeyPair c, AllIssuerKeys c 'GenesisDelegate)]
coreNodes [AllIssuerKeys c 'GenesisDelegate]
genesisDelegates =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall {c} {kd :: KeyRole}.
Crypto c =>
AllIssuerKeys c kd -> (KeyHash kd c, 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 c, AllIssuerKeys c kd)
f AllIssuerKeys c kd
issuerKeys = (forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey forall a b. (a -> b) -> a -> b
$ forall v (r :: KeyRole). AllIssuerKeys v r -> KeyPair r v
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 c, 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 :: Crypto c => KeyPairs c -> Map (KeyHash 'Staking c) (KeyPair 'Staking c)
mkStakeKeyHashMap :: forall c.
Crypto c =>
KeyPairs c -> Map (KeyHash 'Staking c) (KeyPair 'Staking c)
mkStakeKeyHashMap KeyPairs c
keyPairs =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall {c} {a} {kd :: KeyRole}.
Crypto c =>
(a, KeyPair kd c) -> (KeyHash kd c, KeyPair kd c)
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyPairs c
keyPairs)
  where
    f :: (a, KeyPair kd c) -> (KeyHash kd c, KeyPair kd c)
f (a
_payK, KeyPair kd c
stakeK) = ((forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey) KeyPair kd c
stakeK, KeyPair kd c
stakeK)

-- | Generate a mapping from payment key hash to keypair
-- from a list of (payment, staking) key pairs.
mkPayKeyHashMap ::
  Crypto c =>
  KeyPairs c ->
  Map (KeyHash 'Payment c) (KeyPair 'Payment c)
mkPayKeyHashMap :: forall c.
Crypto c =>
KeyPairs c -> Map (KeyHash 'Payment c) (KeyPair 'Payment c)
mkPayKeyHashMap KeyPairs c
keyPairs =
  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall {c} {kd :: KeyRole} {b}.
Crypto c =>
(KeyPair kd c, b) -> (KeyHash kd c, KeyPair kd c)
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyPairs c
keyPairs)
  where
    f :: (KeyPair kd c, b) -> (KeyHash kd c, KeyPair kd c)
f (KeyPair kd c
payK, b
_stakeK) = ((forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
vKey) KeyPair kd c
payK, KeyPair kd c
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 era kr.
  Credential kr (EraCrypto era) ->
  Map (KeyHash kr (EraCrypto era)) (KeyPair kr (EraCrypto era)) ->
  KeyPair kr (EraCrypto era)
findPayKeyPairCred :: forall era (kr :: KeyRole).
Credential kr (EraCrypto era)
-> Map (KeyHash kr (EraCrypto era)) (KeyPair kr (EraCrypto era))
-> KeyPair kr (EraCrypto era)
findPayKeyPairCred (KeyHashObj KeyHash kr (EraCrypto era)
addr) Map (KeyHash kr (EraCrypto era)) (KeyPair kr (EraCrypto era))
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 (EraCrypto era)
addr)
    (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash kr (EraCrypto era)
addr Map (KeyHash kr (EraCrypto era)) (KeyPair kr (EraCrypto era))
keyHashMap)
findPayKeyPairCred Credential kr (EraCrypto era)
_ Map (KeyHash kr (EraCrypto era)) (KeyPair kr (EraCrypto era))
_ =
  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 ::
  forall era.
  Addr (EraCrypto era) ->
  Map (KeyHash 'Payment (EraCrypto era)) (KeyPair 'Payment (EraCrypto era)) ->
  KeyPair 'Payment (EraCrypto era)
findPayKeyPairAddr :: forall era.
Addr (EraCrypto era)
-> Map
     (KeyHash 'Payment (EraCrypto era))
     (KeyPair 'Payment (EraCrypto era))
-> KeyPair 'Payment (EraCrypto era)
findPayKeyPairAddr Addr (EraCrypto era)
a Map
  (KeyHash 'Payment (EraCrypto era))
  (KeyPair 'Payment (EraCrypto era))
keyHashMap =
  case Addr (EraCrypto era)
a of
    Addr Network
_ PaymentCredential (EraCrypto era)
addr (StakeRefBase StakeCredential (EraCrypto era)
_) -> forall era (kr :: KeyRole).
Credential kr (EraCrypto era)
-> Map (KeyHash kr (EraCrypto era)) (KeyPair kr (EraCrypto era))
-> KeyPair kr (EraCrypto era)
findPayKeyPairCred @era PaymentCredential (EraCrypto era)
addr Map
  (KeyHash 'Payment (EraCrypto era))
  (KeyPair 'Payment (EraCrypto era))
keyHashMap
    Addr Network
_ PaymentCredential (EraCrypto era)
addr (StakeRefPtr Ptr
_) -> forall era (kr :: KeyRole).
Credential kr (EraCrypto era)
-> Map (KeyHash kr (EraCrypto era)) (KeyPair kr (EraCrypto era))
-> KeyPair kr (EraCrypto era)
findPayKeyPairCred @era PaymentCredential (EraCrypto era)
addr Map
  (KeyHash 'Payment (EraCrypto era))
  (KeyPair 'Payment (EraCrypto era))
keyHashMap
    Addr (EraCrypto era)
_ ->
      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 (EraCrypto era) ->
  Map (ScriptHash (EraCrypto era)) (Script era, Script era) ->
  (Script era, Script era)
findPayScriptFromCred :: forall era.
Credential 'Witness (EraCrypto era)
-> Map (ScriptHash (EraCrypto era)) (Script era, Script era)
-> (Script era, Script era)
findPayScriptFromCred (ScriptHashObj ScriptHash (EraCrypto era)
scriptHash) Map (ScriptHash (EraCrypto era)) (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 (EraCrypto era)
scriptHash Map (ScriptHash (EraCrypto era)) (Script era, Script era)
scriptsByPayHash)
findPayScriptFromCred Credential 'Witness (EraCrypto era)
_ Map (ScriptHash (EraCrypto era)) (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 (EraCrypto era) ->
  Map (ScriptHash (EraCrypto era)) (Script era, Script era) ->
  (Script era, Script era)
findStakeScriptFromCred :: forall era.
Credential 'Witness (EraCrypto era)
-> Map (ScriptHash (EraCrypto era)) (Script era, Script era)
-> (Script era, Script era)
findStakeScriptFromCred (ScriptHashObj ScriptHash (EraCrypto era)
scriptHash) Map (ScriptHash (EraCrypto era)) (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 (EraCrypto era)
scriptHash Map (ScriptHash (EraCrypto era)) (Script era, Script era)
scriptsByStakeHash)
findStakeScriptFromCred Credential 'Witness (EraCrypto era)
_ Map (ScriptHash (EraCrypto era)) (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 (EraCrypto era) ->
  Map (ScriptHash (EraCrypto era)) (Script era, Script era) ->
  (Script era, Script era)
findPayScriptFromAddr :: forall era.
Addr (EraCrypto era)
-> Map (ScriptHash (EraCrypto era)) (Script era, Script era)
-> (Script era, Script era)
findPayScriptFromAddr (Addr Network
_ PaymentCredential (EraCrypto era)
scriptHash (StakeRefBase StakeCredential (EraCrypto era)
_)) Map (ScriptHash (EraCrypto era)) (Script era, Script era)
scriptsByPayHash =
  forall era.
Credential 'Witness (EraCrypto era)
-> Map (ScriptHash (EraCrypto era)) (Script era, Script era)
-> (Script era, Script era)
findPayScriptFromCred @era (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness PaymentCredential (EraCrypto era)
scriptHash) Map (ScriptHash (EraCrypto era)) (Script era, Script era)
scriptsByPayHash
findPayScriptFromAddr (Addr Network
_ PaymentCredential (EraCrypto era)
scriptHash (StakeRefPtr Ptr
_)) Map (ScriptHash (EraCrypto era)) (Script era, Script era)
scriptsByPayHash =
  forall era.
Credential 'Witness (EraCrypto era)
-> Map (ScriptHash (EraCrypto era)) (Script era, Script era)
-> (Script era, Script era)
findPayScriptFromCred @era (forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness PaymentCredential (EraCrypto era)
scriptHash) Map (ScriptHash (EraCrypto era)) (Script era, Script era)
scriptsByPayHash
findPayScriptFromAddr Addr (EraCrypto era)
_ Map (ScriptHash (EraCrypto era)) (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 c -> Gen (VKey 'Staking c)
pickStakeKey :: forall c. KeyPairs c -> Gen (VKey 'Staking c)
pickStakeKey KeyPairs c
keys = forall (kd :: KeyRole) c. KeyPair kd c -> VKey kd c
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 c
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 (EraCrypto era)] ->
  Gen [TxOut era]
genTxOut :: forall era.
EraTxOut era =>
Gen (Value era) -> [Addr (EraCrypto era)] -> Gen [TxOut era]
genTxOut Gen (Value era)
genEraVal [Addr (EraCrypto era)]
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 (EraCrypto era)]
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 (EraCrypto era) -> 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 (EraCrypto era)]
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)
    ]

-- | Try to map the unit interval to a natural number. We don't care whether
-- this is surjective. But it should be right inverse to `fromNatural` - that
-- is, one should be able to recover the `UnitInterval` value used here.
unitIntervalToNatural :: UnitInterval -> Natural
unitIntervalToNatural :: UnitInterval -> Natural
unitIntervalToNatural UnitInterval
ui =
  forall {a}. Num a => Ratio Integer -> a
toNat ((forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound :: Word64) forall a. Integral a => a -> a -> Ratio a
% Integer
1) forall a. Num a => a -> a -> a
* forall r. BoundedRational r => r -> Ratio Integer
unboundRational UnitInterval
ui)
  where
    toNat :: Ratio Integer -> a
toNat Ratio Integer
r = forall a. Num a => Integer -> a
fromInteger (forall a. Ratio a -> a
numerator Ratio Integer
r forall a. Integral a => a -> a -> a
`quot` forall a. Ratio a -> a
denominator Ratio Integer
r)
{-# DEPRECATED
  unitIntervalToNatural
  "This function has been made private in cardano-protocol-tpraos:testlib. Open an issue if you need it"
  #-}

mkBlockHeader ::
  Mock c =>
  ProtVer ->
  -- | Hash of previous block
  HashHeader c ->
  -- | All keys in the stake pool
  AllIssuerKeys c r ->
  -- | Current slot
  SlotNo ->
  -- | Block number/chain length/chain "difficulty"
  BlockNo ->
  -- | EpochNo nonce
  Nonce ->
  -- | Period of KES (key evolving signature scheme)
  Word ->
  -- | KES period of key registration
  Word ->
  -- | Operational certificate
  OCert c ->
  -- | Block size
  Word32 ->
  -- | Block body hash
  Hash c EraIndependentBlockBody ->
  BHeader c
mkBlockHeader :: forall c (r :: KeyRole).
Mock c =>
ProtVer
-> HashHeader c
-> AllIssuerKeys c r
-> SlotNo
-> BlockNo
-> Nonce
-> Word
-> Word
-> OCert c
-> Word32
-> Hash c EraIndependentBlockBody
-> BHeader c
mkBlockHeader ProtVer
protVer HashHeader c
prev AllIssuerKeys c r
pKeys SlotNo
slotNo BlockNo
blockNo Nonce
enonce Word
kesPeriod Word
c0 OCert c
oCert Word32
bodySize Hash c EraIndependentBlockBody
bodyHash =
  let bhBody :: BHBody c
bhBody = forall v (r :: KeyRole).
(ContextVRF (VRF v) ~ (), Signable (VRF v) Seed,
 VRFAlgorithm (VRF v)) =>
ProtVer
-> HashHeader v
-> AllIssuerKeys v r
-> SlotNo
-> BlockNo
-> Nonce
-> OCert v
-> Word32
-> Hash v EraIndependentBlockBody
-> BHBody v
mkBHBody ProtVer
protVer HashHeader c
prev AllIssuerKeys c r
pKeys SlotNo
slotNo BlockNo
blockNo Nonce
enonce OCert c
oCert Word32
bodySize Hash c EraIndependentBlockBody
bodyHash
   in forall c (r :: KeyRole).
(Crypto c, Signable (KES c) (BHBody c)) =>
AllIssuerKeys c r -> Word -> Word -> BHBody c -> BHeader c
mkBHeader AllIssuerKeys c r
pKeys Word
kesPeriod Word
c0 BHBody c
bhBody
{-# DEPRECATED mkBlockHeader "In favor of `mkBHeader` and `mkBHBody`" #-}

-- | 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 v (r :: KeyRole).
AllIssuerKeys v r -> NonEmpty (KESPeriod, KESKeyPair v)
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
  SlotNo
firstSlotNo <- HasCallStack => EpochInfo Identity -> EpochNo -> ShelleyBase 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 (EraCrypto era) ->
  [TxOut era] ->
  UTxO era
genesisCoins :: forall era. TxId (EraCrypto era) -> [TxOut era] -> UTxO era
genesisCoins TxId (EraCrypto era)
genesisTxId [TxOut era]
outs =
  forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(forall c. TxId c -> TxIx -> TxIn c
TxIn TxId (EraCrypto era)
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 :: forall era. Era era => PV1.Data -> DataHash (EraCrypto era)
hashData :: forall era. Era era => Data -> DataHash (EraCrypto era)
hashData Data
x = forall c index. Hash (HASH c) index -> SafeHash c index
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.
  Era era =>
  GenEnv era ->
  ScriptHash (EraCrypto era) ->
  (Script era, StrictMaybe (DataHash (EraCrypto era)))
findPlutus :: forall era.
Era era =>
GenEnv era
-> ScriptHash (EraCrypto era)
-> (Script era, StrictMaybe (DataHash (EraCrypto era)))
findPlutus (GenEnv KeySpace era
keyspace (ScriptSpace [TwoPhase3ArgInfo era]
_ [TwoPhase2ArgInfo era]
_ Map (ScriptHash (EraCrypto era)) (TwoPhase3ArgInfo era)
mp3 Map (ScriptHash (EraCrypto era)) (TwoPhase2ArgInfo era)
mp2) Constants
_) ScriptHash (EraCrypto era)
hsh =
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash (EraCrypto era)
hsh Map (ScriptHash (EraCrypto era)) (TwoPhase3ArgInfo era)
mp3 of
    Just TwoPhase3ArgInfo era
info3 -> (forall era. TwoPhase3ArgInfo era -> Script era
getScript3 TwoPhase3ArgInfo era
info3, forall a. a -> StrictMaybe a
SJust (forall era. Era era => Data -> DataHash (EraCrypto era)
hashData @era (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 (EraCrypto era)
hsh Map (ScriptHash (EraCrypto era)) (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 (EraCrypto era)
hsh (forall era.
KeySpace era
-> Map (ScriptHash (EraCrypto era)) (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 (EraCrypto era)
hsh (forall era.
KeySpace era
-> Map (ScriptHash (EraCrypto era)) (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 (EraCrypto era)
hsh)