{-# 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)

{------------------------------------------------------------------------------
  ShelleyEra instances for EraGen and ScriptClass
 -----------------------------------------------------------------------------}

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

{------------------------------------------------------------------------------
  ShelleyEra generators
 -----------------------------------------------------------------------------}

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
    , [] -- Shelley does not need any additional script witnesses
    )

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)