{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Test.Cardano.Ledger.Shelley.Generator.ShelleyEraGen (genCoin) where
import qualified Cardano.Crypto.DSIGN as DSIGN
import qualified Cardano.Crypto.KES as KES
import Cardano.Crypto.Util (SignableRepresentation)
import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash)
import Cardano.Ledger.BaseTypes (StrictMaybe (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Crypto (DSIGN, KES)
import qualified Cardano.Ledger.Crypto as CC (Crypto)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.API (
Coin (..),
Update,
)
import Cardano.Ledger.Shelley.Scripts (
MultiSig,
pattern RequireAllOf,
pattern RequireAnyOf,
pattern RequireMOf,
pattern RequireSignature,
)
import Cardano.Ledger.Shelley.TxBody (
ShelleyTxBody (ShelleyTxBody, stbInputs, stbOutputs, stbTxFee),
Withdrawals (..),
)
import Cardano.Ledger.Shelley.TxOut (ShelleyTxOut (..))
import Cardano.Ledger.Shelley.TxWits (ShelleyTxWits (ShelleyTxWits))
import Cardano.Ledger.Slot (SlotNo (..))
import Cardano.Ledger.TxIn (TxIn (..))
import Cardano.Ledger.Val ((<+>))
import Cardano.Protocol.TPraos.API (PraosCrypto)
import Control.Monad (replicateM)
import Data.Foldable (toList)
import Data.Sequence.Strict (StrictSeq ((:|>)), fromList)
import Data.Set (Set)
import Lens.Micro.Extras (view)
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (Mock)
import Test.Cardano.Ledger.Shelley.Constants (Constants (..))
import Test.Cardano.Ledger.Shelley.Generator.Core (
GenEnv (..),
genCoin,
genNatural,
)
import Test.Cardano.Ledger.Shelley.Generator.EraGen (EraGen (..), MinGenTxout (..))
import Test.Cardano.Ledger.Shelley.Generator.ScriptClass (
Quantifier (..),
ScriptClass (..),
)
import Test.Cardano.Ledger.Shelley.Generator.Trace.Chain ()
import Test.Cardano.Ledger.Shelley.Generator.TxAuxData (genMetadata)
import Test.Cardano.Ledger.Shelley.Generator.Update (genPParams, genShelleyPParamsUpdate)
import Test.QuickCheck (Gen)
instance
( PraosCrypto c
, DSIGN.Signable (DSIGN c) ~ SignableRepresentation
, KES.Signable (KES c) ~ SignableRepresentation
) =>
EraGen (ShelleyEra c)
where
genGenesisValue :: GenEnv (ShelleyEra c) -> Gen (Value (ShelleyEra c))
genGenesisValue
( GenEnv
KeySpace (ShelleyEra c)
_keySpace
ScriptSpace (ShelleyEra c)
_scriptspace
Constants {Integer
minGenesisOutputVal :: Constants -> Integer
minGenesisOutputVal :: Integer
minGenesisOutputVal, Integer
maxGenesisOutputVal :: Constants -> Integer
maxGenesisOutputVal :: Integer
maxGenesisOutputVal}
) =
Integer -> Integer -> Gen Coin
genCoin Integer
minGenesisOutputVal Integer
maxGenesisOutputVal
genEraTxBody :: GenEnv (ShelleyEra c)
-> UTxO (ShelleyEra c)
-> PParams (ShelleyEra c)
-> SlotNo
-> Set (TxIn (EraCrypto (ShelleyEra c)))
-> StrictSeq (TxOut (ShelleyEra c))
-> StrictSeq (TxCert (ShelleyEra c))
-> Withdrawals (EraCrypto (ShelleyEra c))
-> Coin
-> StrictMaybe (Update (ShelleyEra c))
-> StrictMaybe (AuxiliaryDataHash (EraCrypto (ShelleyEra c)))
-> Gen (TxBody (ShelleyEra c), [Script (ShelleyEra c)])
genEraTxBody GenEnv (ShelleyEra c)
_ge UTxO (ShelleyEra c)
_utxo = forall era.
(EraTxOut era, EraTxCert era) =>
PParams era
-> SlotNo
-> Set (TxIn (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> Gen (ShelleyTxBody era, [MultiSig era])
genTxBody
genEraAuxiliaryData :: Constants -> Gen (StrictMaybe (TxAuxData (ShelleyEra c)))
genEraAuxiliaryData = forall era.
Era era =>
Constants -> Gen (StrictMaybe (ShelleyTxAuxData era))
genMetadata
updateEraTxBody :: UTxO (ShelleyEra c)
-> PParams (ShelleyEra c)
-> TxWits (ShelleyEra c)
-> TxBody (ShelleyEra c)
-> Coin
-> Set (TxIn (EraCrypto (ShelleyEra c)))
-> TxOut (ShelleyEra c)
-> TxBody (ShelleyEra c)
updateEraTxBody UTxO (ShelleyEra c)
_utxo PParams (ShelleyEra c)
_pp TxWits (ShelleyEra c)
_wits TxBody (ShelleyEra c)
body' Coin
fee Set (TxIn (EraCrypto (ShelleyEra c)))
ins TxOut (ShelleyEra c)
out =
TxBody (ShelleyEra c)
body'
{ stbTxFee :: Coin
stbTxFee = Coin
fee
, stbInputs :: Set (TxIn (EraCrypto (ShelleyEra c)))
stbInputs = forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
ShelleyTxBody era -> Set (TxIn (EraCrypto era))
stbInputs TxBody (ShelleyEra c)
body' forall a. Semigroup a => a -> a -> a
<> Set (TxIn (EraCrypto (ShelleyEra c)))
ins
, stbOutputs :: StrictSeq (TxOut (ShelleyEra c))
stbOutputs = forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
ShelleyTxBody era -> StrictSeq (TxOut era)
stbOutputs TxBody (ShelleyEra c)
body' forall a. StrictSeq a -> a -> StrictSeq a
:|> TxOut (ShelleyEra c)
out
}
genEraPParamsUpdate :: Constants
-> PParams (ShelleyEra c) -> Gen (PParamsUpdate (ShelleyEra c))
genEraPParamsUpdate = forall era.
(ProtVerAtMost era 4, ProtVerAtMost era 6, ProtVerAtMost era 8,
EraPParams era) =>
Constants -> PParams era -> Gen (PParamsUpdate era)
genShelleyPParamsUpdate @(ShelleyEra c)
genEraPParams :: Constants -> Gen (PParams (ShelleyEra c))
genEraPParams = forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
Constants -> Gen (PParams era)
genPParams
genEraTxWits :: (UTxO (ShelleyEra c), TxBody (ShelleyEra c),
ScriptInfo (ShelleyEra c))
-> Set (WitVKey 'Witness (EraCrypto (ShelleyEra c)))
-> Map
(ScriptHash (EraCrypto (ShelleyEra c))) (Script (ShelleyEra c))
-> TxWits (ShelleyEra c)
genEraTxWits (UTxO (ShelleyEra c), TxBody (ShelleyEra c),
ScriptInfo (ShelleyEra c))
_ Set (WitVKey 'Witness (EraCrypto (ShelleyEra c)))
setWitVKey Map (ScriptHash (EraCrypto (ShelleyEra c))) (Script (ShelleyEra c))
mapScriptWit = forall era.
EraScript era =>
Set (WitVKey 'Witness (EraCrypto era))
-> Map (ScriptHash (EraCrypto era)) (Script era)
-> Set (BootstrapWitness (EraCrypto era))
-> ShelleyTxWits era
ShelleyTxWits Set (WitVKey 'Witness (EraCrypto (ShelleyEra c)))
setWitVKey Map (ScriptHash (EraCrypto (ShelleyEra c))) (Script (ShelleyEra c))
mapScriptWit forall a. Monoid a => a
mempty
instance CC.Crypto c => ScriptClass (ShelleyEra c) where
basescript :: Proxy (ShelleyEra c)
-> KeyHash 'Witness (EraCrypto (ShelleyEra c))
-> Script (ShelleyEra c)
basescript Proxy (ShelleyEra c)
_proxy = forall era.
ShelleyEraScript era =>
KeyHash 'Witness (EraCrypto era) -> NativeScript era
RequireSignature
isKey :: Proxy (ShelleyEra c)
-> Script (ShelleyEra c)
-> Maybe (KeyHash 'Witness (EraCrypto (ShelleyEra c)))
isKey Proxy (ShelleyEra c)
_ (RequireSignature KeyHash 'Witness (EraCrypto (ShelleyEra c))
hk) = forall a. a -> Maybe a
Just KeyHash 'Witness (EraCrypto (ShelleyEra c))
hk
isKey Proxy (ShelleyEra c)
_ Script (ShelleyEra c)
_ = forall a. Maybe a
Nothing
quantify :: Proxy (ShelleyEra c)
-> Script (ShelleyEra c) -> Quantifier (Script (ShelleyEra c))
quantify Proxy (ShelleyEra c)
_ (RequireAllOf StrictSeq (NativeScript (ShelleyEra c))
xs) = forall t. [t] -> Quantifier t
AllOf (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq (NativeScript (ShelleyEra c))
xs)
quantify Proxy (ShelleyEra c)
_ (RequireAnyOf StrictSeq (NativeScript (ShelleyEra c))
xs) = forall t. [t] -> Quantifier t
AnyOf (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq (NativeScript (ShelleyEra c))
xs)
quantify Proxy (ShelleyEra c)
_ (RequireMOf Int
n StrictSeq (NativeScript (ShelleyEra c))
xs) = forall t. Int -> [t] -> Quantifier t
MOf Int
n (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq (NativeScript (ShelleyEra c))
xs)
quantify Proxy (ShelleyEra c)
_ Script (ShelleyEra c)
t = forall t. t -> Quantifier t
Leaf Script (ShelleyEra c)
t
unQuantify :: Proxy (ShelleyEra c)
-> Quantifier (Script (ShelleyEra c)) -> Script (ShelleyEra c)
unQuantify Proxy (ShelleyEra c)
_ (AllOf [Script (ShelleyEra c)]
xs) = forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf (forall a. [a] -> StrictSeq a
fromList [Script (ShelleyEra c)]
xs)
unQuantify Proxy (ShelleyEra c)
_ (AnyOf [Script (ShelleyEra c)]
xs) = forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf (forall a. [a] -> StrictSeq a
fromList [Script (ShelleyEra c)]
xs)
unQuantify Proxy (ShelleyEra c)
_ (MOf Int
n [Script (ShelleyEra c)]
xs) = forall era.
ShelleyEraScript era =>
Int -> StrictSeq (NativeScript era) -> NativeScript era
RequireMOf Int
n (forall a. [a] -> StrictSeq a
fromList [Script (ShelleyEra c)]
xs)
unQuantify Proxy (ShelleyEra c)
_ (Leaf Script (ShelleyEra c)
t) = Script (ShelleyEra c)
t
genTxBody ::
( EraTxOut era
, EraTxCert era
) =>
PParams era ->
SlotNo ->
Set (TxIn (EraCrypto era)) ->
StrictSeq (TxOut era) ->
StrictSeq (TxCert era) ->
Withdrawals (EraCrypto era) ->
Coin ->
StrictMaybe (Update era) ->
StrictMaybe (AuxiliaryDataHash (EraCrypto era)) ->
Gen (ShelleyTxBody era, [MultiSig era])
genTxBody :: forall era.
(EraTxOut era, EraTxCert era) =>
PParams era
-> SlotNo
-> Set (TxIn (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> Gen (ShelleyTxBody era, [MultiSig era])
genTxBody PParams era
_pparams SlotNo
slot Set (TxIn (EraCrypto era))
inputs StrictSeq (TxOut era)
outputs StrictSeq (TxCert era)
certs Withdrawals (EraCrypto era)
withdrawals Coin
fee StrictMaybe (Update era)
update StrictMaybe (AuxiliaryDataHash (EraCrypto era))
adHash = do
SlotNo
ttl <- SlotNo -> Gen SlotNo
genTimeToLive SlotNo
slot
forall (m :: * -> *) a. Monad m => a -> m a
return
( forall era.
(EraTxOut era, EncCBOR (TxCert era)) =>
Set (TxIn (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> SlotNo
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> ShelleyTxBody era
ShelleyTxBody
Set (TxIn (EraCrypto era))
inputs
StrictSeq (TxOut era)
outputs
StrictSeq (TxCert era)
certs
Withdrawals (EraCrypto era)
withdrawals
Coin
fee
SlotNo
ttl
StrictMaybe (Update era)
update
StrictMaybe (AuxiliaryDataHash (EraCrypto era))
adHash
, []
)
genTimeToLive :: SlotNo -> Gen SlotNo
genTimeToLive :: SlotNo -> Gen SlotNo
genTimeToLive SlotNo
currentSlot = do
Natural
ttl <- Natural -> Natural -> Gen Natural
genNatural Natural
50 Natural
100
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SlotNo
currentSlot forall a. Num a => a -> a -> a
+ Word64 -> SlotNo
SlotNo (forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
ttl)
instance Mock c => MinGenTxout (ShelleyEra c) where
calcEraMinUTxO :: TxOut (ShelleyEra c) -> PParams (ShelleyEra c) -> Coin
calcEraMinUTxO TxOut (ShelleyEra c)
_txout = forall a s. Getting a s a -> s -> a
view forall era.
(EraPParams era, ProtVerAtMost era 4) =>
Lens' (PParams era) Coin
ppMinUTxOValueL
addValToTxOut :: Value (ShelleyEra c)
-> TxOut (ShelleyEra c) -> TxOut (ShelleyEra c)
addValToTxOut Value (ShelleyEra c)
v (ShelleyTxOut Addr (EraCrypto (ShelleyEra c))
a Value (ShelleyEra c)
u) = forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr (EraCrypto (ShelleyEra c))
a (Value (ShelleyEra c)
v forall t. Val t => t -> t -> t
<+> Value (ShelleyEra c)
u)
genEraTxOut :: GenEnv (ShelleyEra c)
-> Gen (Value (ShelleyEra c))
-> [Addr (EraCrypto (ShelleyEra c))]
-> Gen [TxOut (ShelleyEra c)]
genEraTxOut GenEnv (ShelleyEra c)
_genenv Gen (Value (ShelleyEra c))
genVal [Addr (EraCrypto (ShelleyEra c))]
addrs = do
[Coin]
values <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Addr (EraCrypto (ShelleyEra c))]
addrs) Gen (Value (ShelleyEra c))
genVal
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall era.
(EraTxOut era, HasCallStack) =>
Addr (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut [Addr (EraCrypto (ShelleyEra c))]
addrs [Coin]
values)