{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |  AlonzoEra instances for EraGen and ScriptClass
module Test.Cardano.Ledger.Alonzo.AlonzoEraGen where

import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.Allegra.Scripts (
  AllegraEraScript,
  Timelock (..),
  translateTimelock,
  pattern RequireTimeExpire,
  pattern RequireTimeStart,
 )
import Cardano.Ledger.Allegra.TxAuxData (AllegraTxAuxData (..))
import Cardano.Ledger.Alonzo (AlonzoEra)
import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.PParams
import Cardano.Ledger.Alonzo.Rules (vKeyLocked)
import Cardano.Ledger.Alonzo.Scripts as Alonzo (
  AlonzoPlutusPurpose (..),
  AlonzoScript (..),
  ExUnits (..),
  Prices (..),
  isPlutusScript,
  plutusScriptLanguage,
  pointWiseExUnits,
  toAsIx,
  txscriptfee,
 )
import Cardano.Ledger.Alonzo.Tx (
  AlonzoTx (AlonzoTx),
  IsValid (..),
  hashScriptIntegrity,
  totExUnits,
 )
import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData (..), mkAlonzoTxAuxData)
import Cardano.Ledger.Alonzo.TxBody (
  AlonzoTxBody (..),
  AlonzoTxOut (..),
  inputs',
  utxoEntrySize,
 )
import Cardano.Ledger.Alonzo.TxWits (
  AlonzoTxWits (..),
  Redeemers (..),
  TxDats (..),
  nullRedeemers,
 )
import Cardano.Ledger.Alonzo.UTxO (AlonzoScriptsNeeded (..))
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary (EncCBOR)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Mary (MaryEra)
import Cardano.Ledger.Mary.Value (
  AssetName (..),
  MultiAsset (..),
  PolicyID (..),
  multiAssetFromList,
  policies,
 )
import Cardano.Ledger.Plutus.Data (Data (..))
import Cardano.Ledger.Plutus.Language (Language (..), SLanguage (..))
import Cardano.Ledger.Shelley.PParams (Update)
import Cardano.Ledger.Shelley.Scripts
import Cardano.Ledger.TxIn (TxIn)
import Cardano.Ledger.UTxO (
  EraUTxO (..),
  UTxO (..),
  coinBalance,
  getScriptsNeeded,
  txInsFilter,
 )
import Cardano.Ledger.Val (Val (isAdaOnly, (<+>), (<×>)))
import Control.Monad (replicateM)
import qualified Data.List as List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Proxy (Proxy (..))
import Data.Ratio ((%))
import Data.Sequence.Strict (StrictSeq ((:|>)))
import qualified Data.Sequence.Strict as Seq (fromList)
import Data.Set (Set)
import qualified Data.Set as Set
import Lens.Micro
import Lens.Micro.Extras (view)
import Numeric.Natural (Natural)
import qualified PlutusLedgerApi.Common as P (Data (..))
import System.Random
import Test.Cardano.Ledger.AllegraEraGen (genValidityInterval)
import Test.Cardano.Ledger.Alonzo.Arbitrary (alwaysFails, alwaysSucceeds, mkPlutusScript')
import Test.Cardano.Ledger.Binary.Random
import Test.Cardano.Ledger.Common (tracedDiscard)
import Test.Cardano.Ledger.MaryEraGen (addTokens, genMint, maryGenesisValue, policyIndex)
import Test.Cardano.Ledger.Plutus (zeroTestingCostModels)
import Test.Cardano.Ledger.Plutus.Examples
import Test.Cardano.Ledger.Shelley.Constants (Constants (..))
import Test.Cardano.Ledger.Shelley.Generator.Core (
  GenEnv (..),
  ScriptInfo,
  TwoPhase2ArgInfo (..),
  TwoPhase3ArgInfo (..),
  findPlutus,
  genNatural,
  hashData,
 )
import Test.Cardano.Ledger.Shelley.Generator.EraGen (EraGen (..), MinGenTxout (..))
import Test.Cardano.Ledger.Shelley.Generator.ScriptClass (Quantifier (..), ScriptClass (..))
import Test.Cardano.Ledger.Shelley.Generator.Update (genM, genShelleyPParamsUpdate)
import qualified Test.Cardano.Ledger.Shelley.Generator.Update as Shelley (genPParams)
import Test.Cardano.Ledger.Shelley.Generator.Utxo (encodedLen)
import Test.Cardano.Ledger.Shelley.Utils (unsafeBoundRational)
import Test.QuickCheck hiding ((><))

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

-- | We are choosing new TxOut to pay fees, We want only Key locked addresss with Ada only values.
vKeyLockedAdaOnly :: TxOut AlonzoEra -> Bool
vKeyLockedAdaOnly :: TxOut AlonzoEra -> Bool
vKeyLockedAdaOnly TxOut AlonzoEra
txOut = forall era. EraTxOut era => TxOut era -> Bool
vKeyLocked TxOut AlonzoEra
txOut Bool -> Bool -> Bool
&& forall t. Val t => t -> Bool
isAdaOnly (TxOut AlonzoEra
txOut forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut era => Lens' (TxOut era) (Value era)
valueTxOutL)

phase2scripts3Arg :: forall era. AlonzoEraScript era => [TwoPhase3ArgInfo era]
phase2scripts3Arg :: forall era. AlonzoEraScript era => [TwoPhase3ArgInfo era]
phase2scripts3Arg =
  [ Script era
-> Data -> (Data, Natural, Natural) -> Bool -> TwoPhase3ArgInfo era
mkTwoPhase3ArgInfo (forall (l :: Language) era.
(HasCallStack, PlutusLanguage l, AlonzoEraScript era) =>
Natural -> Script era
alwaysSucceeds @'PlutusV1 Natural
3) (Integer -> Data
P.I Integer
1) (Integer -> Data
P.I Integer
1, Natural
bigMem, Natural
bigStep) Bool
True
  , Script era
-> Data -> (Data, Natural, Natural) -> Bool -> TwoPhase3ArgInfo era
mkTwoPhase3ArgInfo
      (forall era (l :: Language).
(HasCallStack, AlonzoEraScript era, PlutusLanguage l) =>
Plutus l -> Script era
mkPlutusScript' (forall (l :: Language). SLanguage l -> Plutus l
redeemerSameAsDatum SLanguage 'PlutusV1
SPlutusV1))
      (Integer -> Data
P.I Integer
9)
      (Integer -> Data
P.I Integer
9, Natural
bigMem, Natural
bigStep)
      Bool
True
  , Script era
-> Data -> (Data, Natural, Natural) -> Bool -> TwoPhase3ArgInfo era
mkTwoPhase3ArgInfo (forall era (l :: Language).
(HasCallStack, AlonzoEraScript era, PlutusLanguage l) =>
Plutus l -> Script era
mkPlutusScript' (forall (l :: Language). SLanguage l -> Plutus l
evenDatum SLanguage 'PlutusV1
SPlutusV1)) (Integer -> Data
P.I Integer
8) (Integer -> Data
P.I Integer
8, Natural
bigMem, Natural
bigStep) Bool
True
  , Script era
-> Data -> (Data, Natural, Natural) -> Bool -> TwoPhase3ArgInfo era
mkTwoPhase3ArgInfo (forall (l :: Language) era.
(HasCallStack, PlutusLanguage l, AlonzoEraScript era) =>
Natural -> Script era
alwaysFails @'PlutusV1 Natural
3) (Integer -> Data
P.I Integer
1) (Integer -> Data
P.I Integer
1, Natural
bigMem, Natural
bigStep) Bool
False
  , Script era
-> Data -> (Data, Natural, Natural) -> Bool -> TwoPhase3ArgInfo era
mkTwoPhase3ArgInfo
      (forall era (l :: Language).
(HasCallStack, AlonzoEraScript era, PlutusLanguage l) =>
Plutus l -> Script era
mkPlutusScript' (forall (l :: Language). SLanguage l -> Plutus l
purposeIsWellformedWithDatum SLanguage 'PlutusV1
SPlutusV1))
      (Integer -> Data
P.I Integer
3)
      (Integer -> Data
P.I Integer
4, Natural
bigMem, Natural
bigStep)
      Bool
True
  , Script era
-> Data -> (Data, Natural, Natural) -> Bool -> TwoPhase3ArgInfo era
mkTwoPhase3ArgInfo
      (forall era (l :: Language).
(HasCallStack, AlonzoEraScript era, PlutusLanguage l) =>
Plutus l -> Script era
mkPlutusScript' (forall (l :: Language). SLanguage l -> Plutus l
datumIsWellformed SLanguage 'PlutusV1
SPlutusV1))
      (Integer -> Data
P.I Integer
5)
      (Integer -> Data
P.I Integer
6, Natural
bigMem, Natural
bigStep)
      Bool
True
  , Script era
-> Data -> (Data, Natural, Natural) -> Bool -> TwoPhase3ArgInfo era
mkTwoPhase3ArgInfo
      (forall era (l :: Language).
(HasCallStack, AlonzoEraScript era, PlutusLanguage l) =>
Plutus l -> Script era
mkPlutusScript' (forall (l :: Language). SLanguage l -> Plutus l
inputsOutputsAreNotEmptyWithDatum SLanguage 'PlutusV1
SPlutusV1))
      (Integer -> Data
P.I Integer
7)
      (Integer -> Data
P.I Integer
9, Natural
bigMem, Natural
bigStep)
      Bool
True
  ]
  where
    mkTwoPhase3ArgInfo :: Script era
-> Data -> (Data, Natural, Natural) -> Bool -> TwoPhase3ArgInfo era
mkTwoPhase3ArgInfo Script era
script = forall era.
Script era
-> ScriptHash
-> Data
-> (Data, Natural, Natural)
-> Bool
-> TwoPhase3ArgInfo era
TwoPhase3ArgInfo Script era
script (forall era. EraScript era => Script era -> ScriptHash
hashScript @era Script era
script)

phase2scripts2Arg :: forall era. AlonzoEraScript era => [TwoPhase2ArgInfo era]
phase2scripts2Arg :: forall era. AlonzoEraScript era => [TwoPhase2ArgInfo era]
phase2scripts2Arg =
  [ Script era
-> (Data, Natural, Natural) -> Bool -> TwoPhase2ArgInfo era
mkTwoPhase2ArgInfo (forall (l :: Language) era.
(HasCallStack, PlutusLanguage l, AlonzoEraScript era) =>
Natural -> Script era
alwaysSucceeds @'PlutusV1 Natural
2) (Integer -> Data
P.I Integer
1, Natural
bigMem, Natural
bigStep) Bool
True
  , Script era
-> (Data, Natural, Natural) -> Bool -> TwoPhase2ArgInfo era
mkTwoPhase2ArgInfo (forall era (l :: Language).
(HasCallStack, AlonzoEraScript era, PlutusLanguage l) =>
Plutus l -> Script era
mkPlutusScript' (forall (l :: Language). SLanguage l -> Plutus l
evenRedeemerNoDatum SLanguage 'PlutusV1
SPlutusV1)) (Integer -> Data
P.I Integer
14, Natural
bigMem, Natural
bigStep) Bool
True
  , Script era
-> (Data, Natural, Natural) -> Bool -> TwoPhase2ArgInfo era
mkTwoPhase2ArgInfo (forall (l :: Language) era.
(HasCallStack, PlutusLanguage l, AlonzoEraScript era) =>
Natural -> Script era
alwaysFails @'PlutusV1 Natural
2) (Integer -> Data
P.I Integer
1, Natural
bigMem, Natural
bigStep) Bool
False
  , Script era
-> (Data, Natural, Natural) -> Bool -> TwoPhase2ArgInfo era
mkTwoPhase2ArgInfo
      (forall era (l :: Language).
(HasCallStack, AlonzoEraScript era, PlutusLanguage l) =>
Plutus l -> Script era
mkPlutusScript' (forall (l :: Language). SLanguage l -> Plutus l
purposeIsWellformedNoDatum SLanguage 'PlutusV1
SPlutusV1))
      (Integer -> Data
P.I Integer
14, Natural
bigMem, Natural
bigStep)
      Bool
True
  , Script era
-> (Data, Natural, Natural) -> Bool -> TwoPhase2ArgInfo era
mkTwoPhase2ArgInfo
      (forall era (l :: Language).
(HasCallStack, AlonzoEraScript era, PlutusLanguage l) =>
Plutus l -> Script era
mkPlutusScript' (forall (l :: Language). SLanguage l -> Plutus l
inputsOutputsAreNotEmptyNoDatum SLanguage 'PlutusV1
SPlutusV1))
      (Integer -> Data
P.I Integer
15, Natural
bigMem, Natural
bigStep)
      Bool
True
  ]
  where
    mkTwoPhase2ArgInfo :: Script era
-> (Data, Natural, Natural) -> Bool -> TwoPhase2ArgInfo era
mkTwoPhase2ArgInfo Script era
script = forall era.
Script era
-> ScriptHash
-> (Data, Natural, Natural)
-> Bool
-> TwoPhase2ArgInfo era
TwoPhase2ArgInfo Script era
script (forall era. EraScript era => Script era -> ScriptHash
hashScript @era Script era
script)

phase2scripts3ArgSucceeds :: forall era. AlonzoEraScript era => Script era -> Bool
phase2scripts3ArgSucceeds :: forall era. AlonzoEraScript era => Script era -> Bool
phase2scripts3ArgSucceeds Script era
script =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True forall era. TwoPhase3ArgInfo era -> Bool
getSucceeds3 forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\TwoPhase3ArgInfo era
info -> forall era. TwoPhase3ArgInfo era -> Script era
getScript3 TwoPhase3ArgInfo era
info forall a. Eq a => a -> a -> Bool
== Script era
script) forall era. AlonzoEraScript era => [TwoPhase3ArgInfo era]
phase2scripts3Arg

phase2scripts2ArgSucceeds :: forall era. AlonzoEraScript era => Script era -> Bool
phase2scripts2ArgSucceeds :: forall era. AlonzoEraScript era => Script era -> Bool
phase2scripts2ArgSucceeds Script era
script =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True forall era. TwoPhase2ArgInfo era -> Bool
getSucceeds2 forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\TwoPhase2ArgInfo era
info -> forall era. TwoPhase2ArgInfo era -> Script era
getScript2 TwoPhase2ArgInfo era
info forall a. Eq a => a -> a -> Bool
== Script era
script) forall era. AlonzoEraScript era => [TwoPhase2ArgInfo era]
phase2scripts2Arg

genPlutus2Arg :: AlonzoEraScript era => Gen (Maybe (TwoPhase2ArgInfo era))
genPlutus2Arg :: forall era.
AlonzoEraScript era =>
Gen (Maybe (TwoPhase2ArgInfo era))
genPlutus2Arg = forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
10, forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HasCallStack => [a] -> Gen a
elements forall era. AlonzoEraScript era => [TwoPhase2ArgInfo era]
phase2scripts2Arg), (Int
90, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)]

-- | Gen a Mint value in the Alonzo Era, with a 10% chance that it includes an AlonzoScript
genAlonzoMint :: MultiAsset -> Gen (MultiAsset, [AlonzoScript AlonzoEra])
genAlonzoMint :: MultiAsset -> Gen (MultiAsset, [AlonzoScript AlonzoEra])
genAlonzoMint MultiAsset
startvalue = do
  Maybe (TwoPhase2ArgInfo AlonzoEra)
ans <- forall era.
AlonzoEraScript era =>
Gen (Maybe (TwoPhase2ArgInfo era))
genPlutus2Arg
  case Maybe (TwoPhase2ArgInfo AlonzoEra)
ans of
    Maybe (TwoPhase2ArgInfo AlonzoEra)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (MultiAsset
startvalue, [])
    Just (TwoPhase2ArgInfo Script AlonzoEra
script ScriptHash
shash (Data, Natural, Natural)
_ Bool
_) -> do
      Integer
count <- forall a. Enum a => (a, a) -> Gen a
chooseEnum (Integer
1, Integer
10)
      let assetname :: AssetName
assetname = ShortByteString -> AssetName
AssetName ShortByteString
"purple"
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(PolicyID, AssetName, Integer)] -> MultiAsset
multiAssetFromList [(ScriptHash -> PolicyID
PolicyID ScriptHash
shash, AssetName
assetname, Integer
count)] forall a. Semigroup a => a -> a -> a
<> MultiAsset
startvalue, [Script AlonzoEra
script])

genPair :: Gen a -> Gen b -> Gen (a, b)
genPair :: forall a b. Gen a -> Gen b -> Gen (a, b)
genPair Gen a
x Gen b
y = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen b
y

genPlutusData :: Gen P.Data
genPlutusData :: Gen Data
genPlutusData = forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
5 (forall a. (Int -> Gen a) -> Gen a
sized forall {t}. Integral t => t -> Gen Data
gendata)
  where
    gendata :: t -> Gen Data
gendata t
n
      | t
n forall a. Ord a => a -> a -> Bool
> t
0 =
          forall a. HasCallStack => [Gen a] -> Gen a
oneof
            [ Integer -> Data
P.I forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
            , ByteString -> Data
P.B forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
            , [(Data, Data)] -> Data
P.Map forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> Gen [a]
listOf (forall a b. Gen a -> Gen b -> Gen (a, b)
genPair (t -> Gen Data
gendata (t
n forall a. Integral a => a -> a -> a
`div` t
2)) (t -> Gen Data
gendata (t
n forall a. Integral a => a -> a -> a
`div` t
2)))
            , Integer -> [Data] -> Data
P.Constr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Gen a -> Gen [a]
listOf (t -> Gen Data
gendata (t
n forall a. Integral a => a -> a -> a
`div` t
2))
            , [Data] -> Data
P.List forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> Gen [a]
listOf (t -> Gen Data
gendata (t
n forall a. Integral a => a -> a -> a
`div` t
2))
            ]
    gendata t
_ = forall a. HasCallStack => [Gen a] -> Gen a
oneof [Integer -> Data
P.I forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary, ByteString -> Data
P.B forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary]

genSet :: Ord a => Gen a -> Gen (Set a)
genSet :: forall a. Ord a => Gen a -> Gen (Set a)
genSet Gen a
gen =
  forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
    [ (Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Set a
Set.empty)
    , (Int
2, forall a. Ord a => [a] -> Set a
Set.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Gen a
gen])
    , (Int
1, forall a. Ord a => [a] -> Set a
Set.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Gen a
gen, Gen a
gen])
    ]

genAux :: Constants -> Gen (StrictMaybe (AlonzoTxAuxData AlonzoEra))
genAux :: Constants -> Gen (StrictMaybe (AlonzoTxAuxData AlonzoEra))
genAux Constants
constants = do
  StrictMaybe (AllegraTxAuxData MaryEra)
maybeAux <- forall era.
EraGen era =>
Constants -> Gen (StrictMaybe (TxAuxData era))
genEraAuxiliaryData @MaryEra Constants
constants
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      (\(AllegraTxAuxData Map Word64 Metadatum
x StrictSeq (Timelock MaryEra)
y) -> forall (f :: * -> *) era.
(Foldable f, AlonzoEraScript era) =>
Map Word64 Metadatum -> f (AlonzoScript era) -> AlonzoTxAuxData era
mkAlonzoTxAuxData Map Word64 Metadatum
x (forall era. Timelock era -> AlonzoScript era
TimelockScript forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era1 era2.
(Era era1, Era era2) =>
Timelock era1 -> Timelock era2
translateTimelock forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq (Timelock MaryEra)
y))
      StrictMaybe (AllegraTxAuxData MaryEra)
maybeAux

instance ScriptClass AlonzoEra where
  basescript :: Proxy AlonzoEra -> KeyHash 'Witness -> Script AlonzoEra
basescript = forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
Proxy era -> KeyHash 'Witness -> AlonzoScript era
someLeaf
  isKey :: Proxy AlonzoEra -> Script AlonzoEra -> Maybe (KeyHash 'Witness)
isKey Proxy AlonzoEra
_ (TimelockScript Timelock AlonzoEra
x) = forall era.
ScriptClass era =>
Proxy era -> Script era -> Maybe (KeyHash 'Witness)
isKey (forall {k} (t :: k). Proxy t
Proxy @MaryEra) forall a b. (a -> b) -> a -> b
$ forall era1 era2.
(Era era1, Era era2) =>
Timelock era1 -> Timelock era2
translateTimelock Timelock AlonzoEra
x
  isKey Proxy AlonzoEra
_ (PlutusScript PlutusScript AlonzoEra
_) = forall a. Maybe a
Nothing
  isOnePhase :: Proxy AlonzoEra -> Script AlonzoEra -> Bool
isOnePhase Proxy AlonzoEra
_ (TimelockScript Timelock AlonzoEra
_) = Bool
True
  isOnePhase Proxy AlonzoEra
_ (PlutusScript PlutusScript AlonzoEra
_) = Bool
False
  quantify :: Proxy AlonzoEra
-> Script AlonzoEra -> Quantifier (Script AlonzoEra)
quantify Proxy AlonzoEra
_ (TimelockScript Timelock AlonzoEra
x) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall era. Timelock era -> AlonzoScript era
TimelockScript forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era1 era2.
(Era era1, Era era2) =>
Timelock era1 -> Timelock era2
translateTimelock) (forall era.
ScriptClass era =>
Proxy era -> Script era -> Quantifier (Script era)
quantify (forall {k} (t :: k). Proxy t
Proxy @MaryEra) (forall era1 era2.
(Era era1, Era era2) =>
Timelock era1 -> Timelock era2
translateTimelock Timelock AlonzoEra
x))
  quantify Proxy AlonzoEra
_ Script AlonzoEra
x = forall t. t -> Quantifier t
Leaf Script AlonzoEra
x
  unQuantify :: Proxy AlonzoEra
-> Quantifier (Script AlonzoEra) -> Script AlonzoEra
unQuantify Proxy AlonzoEra
_ Quantifier (Script AlonzoEra)
quant =
    forall era. Timelock era -> AlonzoScript era
TimelockScript forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era1 era2.
(Era era1, Era era2) =>
Timelock era1 -> Timelock era2
translateTimelock forall a b. (a -> b) -> a -> b
$
      forall era.
ScriptClass era =>
Proxy era -> Quantifier (Script era) -> Script era
unQuantify (forall {k} (t :: k). Proxy t
Proxy @MaryEra) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall era1 era2.
(Era era1, Era era2) =>
Timelock era1 -> Timelock era2
translateTimelock forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. AlonzoScript era -> Timelock era
unTime) Quantifier (Script AlonzoEra)
quant)

unTime :: AlonzoScript era -> Timelock era
unTime :: forall era. AlonzoScript era -> Timelock era
unTime (TimelockScript Timelock era
x) = Timelock era
x
unTime (PlutusScript PlutusScript era
_) = forall a. HasCallStack => [Char] -> a
error [Char]
"Plutus in Timelock"

okAsCollateral :: UTxO AlonzoEra -> TxIn -> Bool
okAsCollateral :: UTxO AlonzoEra -> TxIn -> Bool
okAsCollateral UTxO AlonzoEra
utxo TxIn
inputx =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False TxOut AlonzoEra -> Bool
vKeyLockedAdaOnly forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn
inputx (forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO UTxO AlonzoEra
utxo)

genAlonzoTxBody ::
  GenEnv AlonzoEra ->
  UTxO AlonzoEra ->
  PParams AlonzoEra ->
  SlotNo ->
  Set.Set TxIn ->
  StrictSeq (TxOut AlonzoEra) ->
  StrictSeq (TxCert AlonzoEra) ->
  Withdrawals ->
  Coin ->
  StrictMaybe (Update AlonzoEra) ->
  StrictMaybe TxAuxDataHash ->
  Gen (TxBody AlonzoEra, [Script AlonzoEra])
genAlonzoTxBody :: GenEnv AlonzoEra
-> UTxO AlonzoEra
-> PParams AlonzoEra
-> SlotNo
-> Set TxIn
-> StrictSeq (TxOut AlonzoEra)
-> StrictSeq (TxCert AlonzoEra)
-> Withdrawals
-> Coin
-> StrictMaybe (Update AlonzoEra)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody AlonzoEra, [Script AlonzoEra])
genAlonzoTxBody GenEnv AlonzoEra
_genenv UTxO AlonzoEra
utxo PParams AlonzoEra
pparams SlotNo
currentslot Set TxIn
input StrictSeq (TxOut AlonzoEra)
txOuts StrictSeq (TxCert AlonzoEra)
certs Withdrawals
withdrawals Coin
fee StrictMaybe (Update AlonzoEra)
updates StrictMaybe TxAuxDataHash
auxDHash = do
  StrictMaybe Network
netid <- forall a. Gen a -> Gen (StrictMaybe a)
genM forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Network
Testnet -- frequency [(2, pure Mainnet), (1, pure Testnet)]
  MultiAsset
startvalue <- Gen MultiAsset
genMint
  (MultiAsset
minted, [AlonzoScript AlonzoEra]
plutusScripts) <- MultiAsset -> Gen (MultiAsset, [AlonzoScript AlonzoEra])
genAlonzoMint MultiAsset
startvalue
  let (MultiAsset
minted2, StrictSeq (AlonzoTxOut AlonzoEra)
txouts2) = case forall era.
(EraGen era, Value era ~ MaryValue) =>
Proxy era
-> StrictSeq (TxOut era)
-> PParams era
-> MultiAsset
-> StrictSeq (TxOut era)
-> Maybe (StrictSeq (TxOut era))
addTokens (forall {k} (t :: k). Proxy t
Proxy @AlonzoEra) forall a. Monoid a => a
mempty PParams AlonzoEra
pparams MultiAsset
minted StrictSeq (TxOut AlonzoEra)
txOuts of
        Maybe (StrictSeq (TxOut AlonzoEra))
Nothing -> (forall a. Monoid a => a
mempty, StrictSeq (TxOut AlonzoEra)
txOuts)
        Just StrictSeq (TxOut AlonzoEra)
os -> (MultiAsset
minted, StrictSeq (TxOut AlonzoEra)
os)
      scriptsFromPolicies :: [Timelock AlonzoEra]
scriptsFromPolicies = (forall era. AllegraEraScript era => Map PolicyID (NativeScript era)
policyIndex forall k a. Ord k => Map k a -> k -> a
Map.!) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toList (MultiAsset -> Set PolicyID
policies MultiAsset
startvalue)
      txouts3 :: StrictSeq (AlonzoTxOut AlonzoEra)
txouts3 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxOut AlonzoEra -> TxOut AlonzoEra
addMaybeDataHashToTxOut StrictSeq (AlonzoTxOut AlonzoEra)
txouts2
  ValidityInterval
validityInterval <- SlotNo -> Gen ValidityInterval
genValidityInterval SlotNo
currentslot
  forall (m :: * -> *) a. Monad m => a -> m a
return
    ( forall era.
(EraTxOut era, EraTxCert era) =>
Set TxIn
-> Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> ValidityInterval
-> StrictMaybe (Update era)
-> Set (KeyHash 'Witness)
-> MultiAsset
-> StrictMaybe ScriptIntegrityHash
-> StrictMaybe TxAuxDataHash
-> StrictMaybe Network
-> AlonzoTxBody era
AlonzoTxBody
        Set TxIn
input
        (forall a. (a -> Bool) -> Set a -> Set a
Set.filter (UTxO AlonzoEra -> TxIn -> Bool
okAsCollateral UTxO AlonzoEra
utxo) Set TxIn
input) -- Set.empty -- collateral -- TODO do something better here (use genenv ?)
        StrictSeq (AlonzoTxOut AlonzoEra)
txouts3
        StrictSeq (TxCert AlonzoEra)
certs
        Withdrawals
withdrawals
        Coin
fee
        ValidityInterval
validityInterval -- (ValidityInterval SNothing SNothing) -- (ValidityInterval low high)
        StrictMaybe (Update AlonzoEra)
updates
        -- reqSignerHashes
        forall a. Set a
Set.empty -- TODO do something better here
        MultiAsset
minted2
        -- scriptIntegrityHash starts out with empty Redeemers,
        -- as Remdeemers are added it is recomputed in updateEraTxBody
        (forall era.
AlonzoEraScript era =>
Set LangDepView
-> Redeemers era -> TxDats era -> StrictMaybe ScriptIntegrityHash
hashScriptIntegrity @AlonzoEra forall a. Set a
Set.empty (forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers forall k a. Map k a
Map.empty) (forall era. Era era => Map DataHash (Data era) -> TxDats era
TxDats forall k a. Map k a
Map.empty))
        StrictMaybe TxAuxDataHash
auxDHash
        StrictMaybe Network
netid
    , forall a b. (a -> b) -> [a] -> [b]
List.map forall era. Timelock era -> AlonzoScript era
TimelockScript [Timelock AlonzoEra]
scriptsFromPolicies forall a. Semigroup a => a -> a -> a
<> [AlonzoScript AlonzoEra]
plutusScripts
    )

genSlotAfter :: SlotNo -> Gen SlotNo
genSlotAfter :: SlotNo -> Gen SlotNo
genSlotAfter 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)

-- | Gen an Alonzo PParamsUpdate, by adding to a Shelley PParamsData
genAlonzoPParamsUpdate ::
  Constants ->
  PParams AlonzoEra ->
  Gen (PParamsUpdate AlonzoEra)
genAlonzoPParamsUpdate :: Constants -> PParams AlonzoEra -> Gen (PParamsUpdate AlonzoEra)
genAlonzoPParamsUpdate Constants
constants PParams AlonzoEra
pp = do
  PParamsUpdate MaryEra
maryPPUpdate <-
    forall era.
(ProtVerAtMost era 4, ProtVerAtMost era 6, ProtVerAtMost era 8,
 EraPParams era) =>
Constants -> PParams era -> Gen (PParamsUpdate era)
genShelleyPParamsUpdate @MaryEra Constants
constants forall a b. (a -> b) -> a -> b
$
      forall era.
(EraPParams era, EraPParams (PreviousEra era)) =>
DowngradePParams Identity era
-> PParams era -> PParams (PreviousEra era)
downgradePParams (DowngradeAlonzoPParams {dappMinUTxOValue :: HKD Identity Coin
dappMinUTxOValue = Integer -> Coin
Coin Integer
100}) PParams AlonzoEra
pp
  StrictMaybe CoinPerWord
coinPerWord <- forall a. Gen a -> Gen (StrictMaybe a)
genM (Coin -> CoinPerWord
CoinPerWord forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Coin
Coin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (Integer
1, Integer
5))
  let genPrice :: Gen NonNegativeInterval
genPrice = forall r.
(HasCallStack, Typeable r, BoundedRational r) =>
Rational -> r
unsafeBoundRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Integral a => a -> a -> Ratio a
% Integer
100) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (Integer
0, Integer
200)
  StrictMaybe Prices
prices <- forall a. Gen a -> Gen (StrictMaybe a)
genM (NonNegativeInterval -> NonNegativeInterval -> Prices
Prices forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen NonNegativeInterval
genPrice forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen NonNegativeInterval
genPrice)
  StrictMaybe ExUnits
maxTxExUnits <- forall a. Gen a -> Gen (StrictMaybe a)
genM Gen ExUnits
genMaxTxExUnits
  StrictMaybe ExUnits
maxBlockExUnits <- forall a. Gen a -> Gen (StrictMaybe a)
genM Gen ExUnits
genMaxBlockExUnits
  -- Not too small for maxValSize, if this is too small then any Tx with Value
  -- that has lots of policyIds will fail. The Shelley Era uses hard coded 4000
  StrictMaybe Natural
maxValSize <- forall a. Gen a -> Gen (StrictMaybe a)
genM (Natural -> Natural -> Gen Natural
genNatural Natural
4000 Natural
5000)
  let alonzoUpgrade :: UpgradeAlonzoPParams StrictMaybe
alonzoUpgrade =
        UpgradeAlonzoPParams
          { uappCoinsPerUTxOWord :: HKD StrictMaybe CoinPerWord
uappCoinsPerUTxOWord = StrictMaybe CoinPerWord
coinPerWord
          , uappCostModels :: HKD StrictMaybe CostModels
uappCostModels = forall a. a -> StrictMaybe a
SJust forall a b. (a -> b) -> a -> b
$ HasCallStack => [Language] -> CostModels
zeroTestingCostModels [Language
PlutusV1]
          , uappPrices :: HKD StrictMaybe Prices
uappPrices = StrictMaybe Prices
prices
          , uappMaxTxExUnits :: HKD StrictMaybe ExUnits
uappMaxTxExUnits = StrictMaybe ExUnits
maxTxExUnits
          , uappMaxBlockExUnits :: HKD StrictMaybe ExUnits
uappMaxBlockExUnits = StrictMaybe ExUnits
maxBlockExUnits
          , uappMaxValSize :: HKD StrictMaybe Natural
uappMaxValSize = StrictMaybe Natural
maxValSize
          , uappCollateralPercentage :: HKD StrictMaybe Natural
uappCollateralPercentage = forall a. a -> StrictMaybe a
SJust Natural
25 -- percent of fee in collateral
          , uappMaxCollateralInputs :: HKD StrictMaybe Natural
uappMaxCollateralInputs = forall a. a -> StrictMaybe a
SJust Natural
100 -- max number of inputs in collateral
          }
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
(EraPParams era, EraPParams (PreviousEra era)) =>
UpgradePParams StrictMaybe era
-> PParamsUpdate (PreviousEra era) -> PParamsUpdate era
upgradePParamsUpdate UpgradeAlonzoPParams StrictMaybe
alonzoUpgrade PParamsUpdate MaryEra
maryPPUpdate

genAlonzoPParams ::
  Constants ->
  Gen (PParams AlonzoEra)
genAlonzoPParams :: Constants -> Gen (PParams AlonzoEra)
genAlonzoPParams Constants
constants = do
  -- This ensures that "_d" field is not 0, and that the major protocol version
  -- is large enough to not trigger plutus script failures
  -- (no bultins are alllowed before major version 5).
  PParams MaryEra
maryPP' <- forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
Constants -> Gen (PParams era)
Shelley.genPParams @MaryEra Constants
constants
  let maryPP :: PParams MaryEra
maryPP = PParams MaryEra
maryPP' forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @5) Natural
0
      prices :: Prices
prices = NonNegativeInterval -> NonNegativeInterval -> Prices
Prices forall a. Bounded a => a
minBound forall a. Bounded a => a
minBound
  CoinPerWord
coinPerWord <- Coin -> CoinPerWord
CoinPerWord forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Coin
Coin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (Integer
1, Integer
5)
  -- prices <- Prices <$> (Coin <$> choose (100, 5000)) <*> (Coin <$> choose (100, 5000))
  ExUnits
maxTxExUnits <- Gen ExUnits
genMaxTxExUnits
  ExUnits
maxBlockExUnits <- Gen ExUnits
genMaxBlockExUnits
  Natural
maxValSize <- Natural -> Natural -> Gen Natural
genNatural Natural
4000 Natural
10000 -- This can't be too small. Shelley uses Hard coded 4000
  let alonzoUpgrade :: UpgradeAlonzoPParams Identity
alonzoUpgrade =
        UpgradeAlonzoPParams
          { uappCoinsPerUTxOWord :: HKD Identity CoinPerWord
uappCoinsPerUTxOWord = CoinPerWord
coinPerWord
          , uappCostModels :: HKD Identity CostModels
uappCostModels = HasCallStack => [Language] -> CostModels
zeroTestingCostModels [Language
PlutusV1]
          , uappPrices :: HKD Identity Prices
uappPrices = Prices
prices
          , uappMaxTxExUnits :: HKD Identity ExUnits
uappMaxTxExUnits = ExUnits
maxTxExUnits
          , uappMaxBlockExUnits :: HKD Identity ExUnits
uappMaxBlockExUnits = ExUnits
maxBlockExUnits
          , uappMaxValSize :: HKD Identity Natural
uappMaxValSize = Natural
maxValSize
          , uappCollateralPercentage :: HKD Identity Natural
uappCollateralPercentage = HKD Identity Natural
25 -- percent of fee in collateral
          , uappMaxCollateralInputs :: HKD Identity Natural
uappMaxCollateralInputs = HKD Identity Natural
100 -- max number of inputs in collateral
          }
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
(EraPParams era, EraPParams (PreviousEra era)) =>
UpgradePParams Identity era
-> PParams (PreviousEra era) -> PParams era
upgradePParams UpgradeAlonzoPParams Identity
alonzoUpgrade PParams MaryEra
maryPP

bigMem :: Natural
bigMem :: Natural
bigMem = Natural
50000

bigStep :: Natural
bigStep :: Natural
bigStep = Natural
99999

genMaxTxExUnits :: Gen ExUnits
genMaxTxExUnits :: Gen ExUnits
genMaxTxExUnits =
  Natural -> Natural -> ExUnits
ExUnits
    -- Accommodate the maximum number of scripts in a transaction
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> Natural -> Gen Natural
genNatural (Natural
10 forall a. Num a => a -> a -> a
* Natural
bigMem forall a. Num a => a -> a -> a
+ Natural
1) (Natural
20 forall a. Num a => a -> a -> a
* Natural
bigMem forall a. Num a => a -> a -> a
+ Natural
1)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Natural -> Natural -> Gen Natural
genNatural (Natural
10 forall a. Num a => a -> a -> a
* Natural
bigStep forall a. Num a => a -> a -> a
+ Natural
1) (Natural
20 forall a. Num a => a -> a -> a
* Natural
bigStep forall a. Num a => a -> a -> a
+ Natural
1)

genMaxBlockExUnits :: Gen ExUnits
genMaxBlockExUnits :: Gen ExUnits
genMaxBlockExUnits =
  Natural -> Natural -> ExUnits
ExUnits
    -- Accommodate the maximum number of scripts in all transactions in a block
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> Natural -> Gen Natural
genNatural (Natural
60 forall a. Num a => a -> a -> a
* Natural
bigMem forall a. Num a => a -> a -> a
+ Natural
1) (Natural
100 forall a. Num a => a -> a -> a
* Natural
bigMem forall a. Num a => a -> a -> a
+ Natural
1)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Natural -> Natural -> Gen Natural
genNatural (Natural
60 forall a. Num a => a -> a -> a
* Natural
bigStep forall a. Num a => a -> a -> a
+ Natural
1) (Natural
100 forall a. Num a => a -> a -> a
* Natural
bigStep forall a. Num a => a -> a -> a
+ Natural
1)

instance EraGen AlonzoEra where
  genEraAuxiliaryData :: Constants -> Gen (StrictMaybe (TxAuxData AlonzoEra))
genEraAuxiliaryData = Constants -> Gen (StrictMaybe (AlonzoTxAuxData AlonzoEra))
genAux
  genGenesisValue :: GenEnv AlonzoEra -> Gen (Value AlonzoEra)
genGenesisValue = forall era. GenEnv era -> Gen MaryValue
maryGenesisValue
  genEraTwoPhase3Arg :: [TwoPhase3ArgInfo AlonzoEra]
genEraTwoPhase3Arg = forall era. AlonzoEraScript era => [TwoPhase3ArgInfo era]
phase2scripts3Arg
  genEraTwoPhase2Arg :: [TwoPhase2ArgInfo AlonzoEra]
genEraTwoPhase2Arg = forall era. AlonzoEraScript era => [TwoPhase2ArgInfo era]
phase2scripts2Arg

  genEraTxBody :: GenEnv AlonzoEra
-> UTxO AlonzoEra
-> PParams AlonzoEra
-> SlotNo
-> Set TxIn
-> StrictSeq (TxOut AlonzoEra)
-> StrictSeq (TxCert AlonzoEra)
-> Withdrawals
-> Coin
-> StrictMaybe (Update AlonzoEra)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody AlonzoEra, [Script AlonzoEra])
genEraTxBody = GenEnv AlonzoEra
-> UTxO AlonzoEra
-> PParams AlonzoEra
-> SlotNo
-> Set TxIn
-> StrictSeq (TxOut AlonzoEra)
-> StrictSeq (TxCert AlonzoEra)
-> Withdrawals
-> Coin
-> StrictMaybe (Update AlonzoEra)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody AlonzoEra, [Script AlonzoEra])
genAlonzoTxBody
  updateEraTxBody :: UTxO AlonzoEra
-> PParams AlonzoEra
-> TxWits AlonzoEra
-> TxBody AlonzoEra
-> Coin
-> Set TxIn
-> TxOut AlonzoEra
-> TxBody AlonzoEra
updateEraTxBody UTxO AlonzoEra
utxo PParams AlonzoEra
pp TxWits AlonzoEra
wits TxBody AlonzoEra
txb Coin
coinx Set TxIn
txin TxOut AlonzoEra
txout =
    TxBody AlonzoEra
txb
      { atbInputs :: Set TxIn
atbInputs = Set TxIn
newInputs
      , atbCollateral :: Set TxIn
atbCollateral = Set TxIn
newCollaterals
      , atbTxFee :: Coin
atbTxFee = Coin
coinx
      , atbOutputs :: StrictSeq (TxOut AlonzoEra)
atbOutputs = StrictSeq (TxOut AlonzoEra)
newOutputs
      , -- The wits may have changed, recompute the scriptIntegrityHash.
        atbScriptIntegrityHash :: StrictMaybe ScriptIntegrityHash
atbScriptIntegrityHash =
          forall era.
AlonzoEraScript era =>
Set LangDepView
-> Redeemers era -> TxDats era -> StrictMaybe ScriptIntegrityHash
hashScriptIntegrity
            Set LangDepView
langViews
            (TxWits AlonzoEra
wits forall s a. s -> Getting a s a -> a
^. forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL)
            (TxWits AlonzoEra
wits forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
datsTxWitsL)
      }
    where
      langs :: Set Language
langs = forall era.
AlonzoEraScript era =>
Map ScriptHash (Script era) -> Set Language
langsUsed @AlonzoEra (TxWits AlonzoEra
wits forall s a. s -> Getting a s a -> a
^. forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL)
      langViews :: Set LangDepView
langViews = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (forall era.
AlonzoEraPParams era =>
PParams era -> Language -> LangDepView
getLanguageView PParams AlonzoEra
pp) Set Language
langs
      requiredCollateral :: Integer
requiredCollateral = forall a b. (RealFrac a, Integral b) => a -> b
ceiling forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (PParams AlonzoEra
pp forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraPParams era => Lens' (PParams era) Natural
ppCollateralPercentageL) forall a. Num a => a -> a -> a
* Coin -> Integer
unCoin Coin
coinx forall a. Integral a => a -> a -> Ratio a
% Integer
100
      potentialCollateral :: Set TxIn
potentialCollateral = forall a. (a -> Bool) -> Set a -> Set a
Set.filter (UTxO AlonzoEra -> TxIn -> Bool
okAsCollateral UTxO AlonzoEra
utxo) Set TxIn
txin
      txInAmounts :: Set TxIn -> [(TxIn, Integer)]
txInAmounts = forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Coin -> Integer
unCoin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting a s a -> s -> a
view forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. UTxO era -> Set TxIn -> UTxO era
txInsFilter UTxO AlonzoEra
utxo
      takeUntilSum :: b -> [(b, b)] -> [b]
takeUntilSum b
s = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (a -> Bool) -> [a] -> [a]
takeUntil ((b
s forall a. Ord a => a -> a -> Bool
>=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> a) -> [a] -> [a]
scanl1 (\(b
_, b
s') (b
x, b
n) -> (b
x, b
s' forall a. Num a => a -> a -> a
+ b
n))
      takeUntil :: (a -> Bool) -> [a] -> [a]
takeUntil a -> Bool
p [a]
xs = let ([a]
y, [a]
n) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span a -> Bool
p [a]
xs in [a]
y forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
take Int
1 [a]
n
      newCollaterals :: Set TxIn
newCollaterals =
        if forall era. Redeemers era -> Bool
nullRedeemers (TxWits AlonzoEra
wits forall s a. s -> Getting a s a -> a
^. forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL)
          then forall a. Monoid a => a
mempty
          else forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b} {b}. (Ord b, Num b) => b -> [(b, b)] -> [b]
takeUntilSum Integer
requiredCollateral forall a b. (a -> b) -> a -> b
$ Set TxIn -> [(TxIn, Integer)]
txInAmounts Set TxIn
potentialCollateral
      newInputs :: Set TxIn
newInputs = forall era.
(EraTxOut era, EraTxCert era) =>
AlonzoTxBody era -> Set TxIn
atbInputs TxBody AlonzoEra
txb forall a. Semigroup a => a -> a -> a
<> Set TxIn
txin
      newOutputs :: StrictSeq (TxOut AlonzoEra)
newOutputs = forall era.
(EraTxOut era, EraTxCert era) =>
AlonzoTxBody era -> StrictSeq (TxOut era)
atbOutputs TxBody AlonzoEra
txb forall a. StrictSeq a -> a -> StrictSeq a
:|> TxOut AlonzoEra
txout

  addInputs :: TxBody AlonzoEra -> Set TxIn -> TxBody AlonzoEra
addInputs TxBody AlonzoEra
txb Set TxIn
txin = TxBody AlonzoEra
txb {atbInputs :: Set TxIn
atbInputs = forall era.
(EraTxOut era, EraTxCert era) =>
AlonzoTxBody era -> Set TxIn
atbInputs TxBody AlonzoEra
txb forall a. Semigroup a => a -> a -> a
<> Set TxIn
txin}

  genEraPParamsUpdate :: Constants -> PParams AlonzoEra -> Gen (PParamsUpdate AlonzoEra)
genEraPParamsUpdate = Constants -> PParams AlonzoEra -> Gen (PParamsUpdate AlonzoEra)
genAlonzoPParamsUpdate
  genEraPParams :: Constants -> Gen (PParams AlonzoEra)
genEraPParams = Constants -> Gen (PParams AlonzoEra)
genAlonzoPParams
  genEraTxWits :: (UTxO AlonzoEra, TxBody AlonzoEra, ScriptInfo AlonzoEra)
-> Set (WitVKey 'Witness)
-> Map ScriptHash (Script AlonzoEra)
-> TxWits AlonzoEra
genEraTxWits (UTxO AlonzoEra
utxo, TxBody AlonzoEra
txbody, ScriptInfo AlonzoEra
scriptinfo) Set (WitVKey 'Witness)
setWitVKey Map ScriptHash (Script AlonzoEra)
mapScriptWit = AlonzoTxWits AlonzoEra
new
    where
      new :: AlonzoTxWits AlonzoEra
new =
        forall era.
AlonzoEraScript era =>
Set (WitVKey 'Witness)
-> Set BootstrapWitness
-> Map ScriptHash (Script era)
-> TxDats era
-> Redeemers era
-> AlonzoTxWits era
AlonzoTxWits
          Set (WitVKey 'Witness)
setWitVKey
          forall a. Set a
Set.empty
          Map ScriptHash (Script AlonzoEra)
mapScriptWit
          -- (dataMapFromTxOut (Prelude.foldr (:) [] (outputs' txbody)) (TxDats (getDataMap scriptinfo mapScriptWit)))
          ([TxOut AlonzoEra] -> TxDats AlonzoEra -> TxDats AlonzoEra
dataMapFromTxOut [TxOut AlonzoEra]
smallUtxo (forall era. Era era => Map DataHash (Data era) -> TxDats era
TxDats (forall era.
Era era =>
ScriptInfo era
-> Map ScriptHash (Script era) -> Map DataHash (Data era)
getDataMap ScriptInfo AlonzoEra
scriptinfo Map ScriptHash (Script AlonzoEra)
mapScriptWit)))
          -- The data hashes come from two places
          (forall era.
AlonzoEraScript era =>
Map (PlutusPurpose AsIx era) (Data era, ExUnits) -> Redeemers era
Redeemers Map (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits)
rdmrMap)
      txinputs :: Set TxIn
txinputs = forall era. AlonzoTxBody era -> Set TxIn
inputs' TxBody AlonzoEra
txbody
      smallUtxo :: [TxOut AlonzoEra]
      smallUtxo :: [TxOut AlonzoEra]
smallUtxo = forall k a. Map k a -> [a]
Map.elems (forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO (forall era. UTxO era -> Set TxIn -> UTxO era
txInsFilter UTxO AlonzoEra
utxo Set TxIn
txinputs))
      AlonzoScriptsNeeded [(PlutusPurpose AsIxItem AlonzoEra, ScriptHash)]
purposeHashPairs = forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded @AlonzoEra UTxO AlonzoEra
utxo TxBody AlonzoEra
txbody
      rdmrMap :: Map (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits)
rdmrMap = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Map (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits)
-> (AlonzoPlutusPurpose AsIxItem AlonzoEra, ScriptHash)
-> Map
     (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits)
accum forall k a. Map k a
Map.empty [(PlutusPurpose AsIxItem AlonzoEra, ScriptHash)]
purposeHashPairs -- Search through the pairs for Plutus scripts
      accum :: Map (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits)
-> (AlonzoPlutusPurpose AsIxItem AlonzoEra, ScriptHash)
-> Map
     (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits)
accum Map (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits)
ans (AlonzoPlutusPurpose AsIxItem AlonzoEra
purpose, ScriptHash
hash1) =
        case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash
hash1 Map ScriptHash (Script AlonzoEra)
mapScriptWit of
          Maybe (AlonzoScript AlonzoEra)
Nothing -> Map (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits)
ans
          Just AlonzoScript AlonzoEra
script ->
            if forall era. EraScript era => Script era -> Bool
isNativeScript @AlonzoEra AlonzoScript AlonzoEra
script
              then Map (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits)
ans -- Native scripts don't have redeemers
              else case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash
hash1 (forall a b. (a, b) -> a
fst ScriptInfo AlonzoEra
scriptinfo) of -- It could be one of the known 3-Arg Plutus Scripts
                Just TwoPhase3ArgInfo AlonzoEra
info -> (Data, Natural, Natural)
-> AlonzoPlutusPurpose AsIxItem AlonzoEra
-> Map
     (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits)
-> Map
     (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits)
addRedeemMap (forall era. TwoPhase3ArgInfo era -> (Data, Natural, Natural)
getRedeemer3 TwoPhase3ArgInfo AlonzoEra
info) AlonzoPlutusPurpose AsIxItem AlonzoEra
purpose Map (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits)
ans -- Add it to the redeemer map
                Maybe (TwoPhase3ArgInfo AlonzoEra)
Nothing -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash
hash1 (forall a b. (a, b) -> b
snd ScriptInfo AlonzoEra
scriptinfo) of -- It could be one of the known 2-Arg Plutus Scripts
                  Just TwoPhase2ArgInfo AlonzoEra
info -> (Data, Natural, Natural)
-> AlonzoPlutusPurpose AsIxItem AlonzoEra
-> Map
     (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits)
-> Map
     (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits)
addRedeemMap (forall era. TwoPhase2ArgInfo era -> (Data, Natural, Natural)
getRedeemer2 TwoPhase2ArgInfo AlonzoEra
info) AlonzoPlutusPurpose AsIxItem AlonzoEra
purpose Map (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits)
ans -- Add it to the redeemer map
                  Maybe (TwoPhase2ArgInfo AlonzoEra)
Nothing -> Map (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits)
ans

  constructTx :: TxBody AlonzoEra
-> TxWits AlonzoEra
-> StrictMaybe (TxAuxData AlonzoEra)
-> Tx AlonzoEra
constructTx TxBody AlonzoEra
bod TxWits AlonzoEra
wit StrictMaybe (TxAuxData AlonzoEra)
auxdata = forall era.
TxBody era
-> TxWits era
-> IsValid
-> StrictMaybe (TxAuxData era)
-> AlonzoTx era
AlonzoTx TxBody AlonzoEra
bod TxWits AlonzoEra
wit (Bool -> IsValid
IsValid Bool
v) StrictMaybe (TxAuxData AlonzoEra)
auxdata
    where
      v :: Bool
v = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all AlonzoScript AlonzoEra -> Bool
twoPhaseValidates (forall era.
Era era =>
AlonzoTxWits era -> Map ScriptHash (Script era)
txscripts' TxWits AlonzoEra
wit)
      twoPhaseValidates :: AlonzoScript AlonzoEra -> Bool
twoPhaseValidates AlonzoScript AlonzoEra
script =
        forall era. EraScript era => Script era -> Bool
isNativeScript @AlonzoEra AlonzoScript AlonzoEra
script
          Bool -> Bool -> Bool
|| (forall era. AlonzoEraScript era => Script era -> Bool
phase2scripts3ArgSucceeds AlonzoScript AlonzoEra
script Bool -> Bool -> Bool
&& forall era. AlonzoEraScript era => Script era -> Bool
phase2scripts2ArgSucceeds AlonzoScript AlonzoEra
script)

  genEraGoodTxOut :: TxOut AlonzoEra -> Bool
genEraGoodTxOut = TxOut AlonzoEra -> Bool
vKeyLockedAdaOnly

  genEraScriptCost :: PParams AlonzoEra -> Script AlonzoEra -> Coin
genEraScriptCost PParams AlonzoEra
pp Script AlonzoEra
script =
    if forall era. AlonzoEraScript era => Script era -> Bool
isPlutusScript Script AlonzoEra
script
      then case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (\TwoPhase3ArgInfo AlonzoEra
info -> forall era. TwoPhase3ArgInfo era -> Script era
getScript3 @AlonzoEra TwoPhase3ArgInfo AlonzoEra
info forall a. Eq a => a -> a -> Bool
== Script AlonzoEra
script) forall era. EraGen era => [TwoPhase3ArgInfo era]
genEraTwoPhase3Arg of
        Just (TwoPhase3ArgInfo Script AlonzoEra
_script ScriptHash
_hash Data
inputdata (Data
rdmr, Natural
mems, Natural
steps) Bool
_succeed) ->
          Prices -> ExUnits -> Coin
txscriptfee (PParams AlonzoEra
pp forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraPParams era => Lens' (PParams era) Prices
ppPricesL) (Natural -> Natural -> ExUnits
ExUnits Natural
mems Natural
steps)
            forall t. Val t => t -> t -> t
<+> forall era t.
(EraPParams era, EncCBOR t) =>
Integer -> PParams era -> t -> Coin
storageCost Integer
10 PParams AlonzoEra
pp (Data
rdmr, Natural -> Natural -> ExUnits
ExUnits Natural
mems Natural
steps) -- Extra 10 for the RdmrPtr
            forall t. Val t => t -> t -> t
<+> forall era t.
(EraPParams era, EncCBOR t) =>
Integer -> PParams era -> t -> Coin
storageCost Integer
32 PParams AlonzoEra
pp Data
inputdata -- Extra 32 for the hash
            forall t. Val t => t -> t -> t
<+> forall era t.
(EraPParams era, EncCBOR t) =>
Integer -> PParams era -> t -> Coin
storageCost Integer
0 PParams AlonzoEra
pp Script AlonzoEra
script
        Maybe (TwoPhase3ArgInfo AlonzoEra)
Nothing -> forall era t.
(EraPParams era, EncCBOR t) =>
Integer -> PParams era -> t -> Coin
storageCost Integer
0 PParams AlonzoEra
pp Script AlonzoEra
script
      else forall era t.
(EraPParams era, EncCBOR t) =>
Integer -> PParams era -> t -> Coin
storageCost Integer
0 PParams AlonzoEra
pp Script AlonzoEra
script

  -- For some reason, the EraGen generators occasionally generate an extra script witness.
  --    There is some evidence that this arises because the script hash appears as the PolicyId
  --    in a Value. But that is not been verified. Regardless of the cause, we can fix this by
  --    discarding the trace. Note that this is failure to generate a "random" but valid
  --    transaction. Discarding the trace adjust for this inadequacy in the generation process.
  --    This only appears in the Alonzo era, so this "fix" is applied here, in the genEraDone
  --    method of the EraGen class in the AlonzoEra instance.
  genEraDone :: UTxO AlonzoEra
-> PParams AlonzoEra -> Tx AlonzoEra -> Gen (Tx AlonzoEra)
genEraDone UTxO AlonzoEra
utxo PParams AlonzoEra
pp Tx AlonzoEra
tx =
    let theFee :: Coin
theFee = Tx AlonzoEra
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL -- Coin supplied to pay fees
        minimumFee :: Coin
minimumFee = forall era.
EraUTxO era =>
PParams era -> Tx era -> UTxO era -> Coin
getMinFeeTxUtxo @AlonzoEra PParams AlonzoEra
pp Tx AlonzoEra
tx UTxO AlonzoEra
utxo
        neededHashes :: Set ScriptHash
neededHashes = forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded forall a b. (a -> b) -> a -> b
$ forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded UTxO AlonzoEra
utxo (Tx AlonzoEra
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL)
        oldScriptWits :: Map ScriptHash (Script AlonzoEra)
oldScriptWits = Tx AlonzoEra
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL
        newWits :: Map ScriptHash (Script AlonzoEra)
newWits = Map ScriptHash (Script AlonzoEra)
oldScriptWits forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set ScriptHash
neededHashes
     in if Coin
minimumFee forall a. Ord a => a -> a -> Bool
<= Coin
theFee
          then
            if Map ScriptHash (Script AlonzoEra)
oldScriptWits forall a. Eq a => a -> a -> Bool
== Map ScriptHash (Script AlonzoEra)
newWits
              then forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx AlonzoEra
tx
              else forall a. [Char] -> a
tracedDiscard forall a b. (a -> b) -> a -> b
$ [Char]
"Random extra scriptwitness: genEraDone: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Map ScriptHash (Script AlonzoEra)
newWits
          else forall a. [Char] -> a
tracedDiscard forall a b. (a -> b) -> a -> b
$ [Char]
"MinFee violation: genEraDone: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Coin
theFee

  genEraTweakBlock :: PParams AlonzoEra -> Seq (Tx AlonzoEra) -> Gen (Seq (Tx AlonzoEra))
genEraTweakBlock PParams AlonzoEra
pp Seq (Tx AlonzoEra)
txns =
    let txTotal, ppMax :: ExUnits
        txTotal :: ExUnits
txTotal = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall era. (EraTx era, AlonzoEraTxWits era) => Tx era -> ExUnits
totExUnits Seq (Tx AlonzoEra)
txns
        ppMax :: ExUnits
ppMax = PParams AlonzoEra
pp forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
ppMaxBlockExUnitsL
     in if (Natural -> Natural -> Bool) -> ExUnits -> ExUnits -> Bool
pointWiseExUnits forall a. Ord a => a -> a -> Bool
(<=) ExUnits
txTotal ExUnits
ppMax
          then forall (f :: * -> *) a. Applicative f => a -> f a
pure Seq (Tx AlonzoEra)
txns
          else
            forall a. [Char] -> a
tracedDiscard forall a b. (a -> b) -> a -> b
$
              [Char]
"TotExUnits violation: genEraTweakBlock: "
                forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (ExUnits -> ExUnits' Natural
unWrapExUnits ExUnits
txTotal)
                forall a. Semigroup a => a -> a -> a
<> [Char]
" instead of "
                forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (ExUnits -> ExUnits' Natural
unWrapExUnits ExUnits
ppMax)

  hasFailedScripts :: Tx AlonzoEra -> Bool
hasFailedScripts Tx AlonzoEra
tx = Bool -> IsValid
IsValid Bool
False forall a. Eq a => a -> a -> Bool
== Tx AlonzoEra
tx forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
isValidTxL

  feeOrCollateral :: Tx AlonzoEra -> UTxO AlonzoEra -> Coin
feeOrCollateral Tx AlonzoEra
tx UTxO AlonzoEra
utxo =
    case Tx AlonzoEra
tx forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
isValidTxL of
      IsValid Bool
True -> Tx AlonzoEra
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL
      IsValid Bool
False -> forall era.
(EraTx era, AlonzoEraTxBody era) =>
Tx era -> UTxO era -> Coin
sumCollateral Tx AlonzoEra
tx UTxO AlonzoEra
utxo

sumCollateral :: (EraTx era, AlonzoEraTxBody era) => Tx era -> UTxO era -> Coin
sumCollateral :: forall era.
(EraTx era, AlonzoEraTxBody era) =>
Tx era -> UTxO era -> Coin
sumCollateral Tx era
tx UTxO era
utxo =
  forall era. EraTxOut era => UTxO era -> Coin
coinBalance forall a b. (a -> b) -> a -> b
$ forall era. UTxO era -> Set TxIn -> UTxO era
txInsFilter UTxO era
utxo forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. AlonzoEraTxBody era => Lens' (TxBody era) (Set TxIn)
collateralInputsTxBodyL

storageCost :: forall era t. (EraPParams era, EncCBOR t) => Integer -> PParams era -> t -> Coin
storageCost :: forall era t.
(EraPParams era, EncCBOR t) =>
Integer -> PParams era -> t -> Coin
storageCost Integer
extra PParams era
pp t
x = (Integer
extra forall a. Num a => a -> a -> a
+ forall era t. (Era era, EncCBOR t) => t -> Integer
encodedLen @era t
x) forall t i. (Val t, Integral i) => i -> t -> t
<×> PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppMinFeeAL

addRedeemMap ::
  (P.Data, Natural, Natural) ->
  AlonzoPlutusPurpose AsIxItem AlonzoEra ->
  Map (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits) ->
  Map (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits)
addRedeemMap :: (Data, Natural, Natural)
-> AlonzoPlutusPurpose AsIxItem AlonzoEra
-> Map
     (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits)
-> Map
     (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits)
addRedeemMap (Data
dat, Natural
space, Natural
steps) AlonzoPlutusPurpose AsIxItem AlonzoEra
purpose Map (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits)
ans =
  let ptr :: PlutusPurpose AsIx AlonzoEra
ptr = forall era (g :: * -> * -> *) (f :: * -> * -> *).
AlonzoEraScript era =>
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
hoistPlutusPurpose forall ix it. AsIxItem ix it -> AsIx ix it
toAsIx AlonzoPlutusPurpose AsIxItem AlonzoEra
purpose
   in forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PlutusPurpose AsIx AlonzoEra
ptr (forall era. Era era => Data -> Data era
Data Data
dat, Natural -> Natural -> ExUnits
ExUnits Natural
space Natural
steps) Map (AlonzoPlutusPurpose AsIx AlonzoEra) (Data AlonzoEra, ExUnits)
ans

getDataMap ::
  forall era.
  Era era =>
  ScriptInfo era ->
  Map ScriptHash (Script era) ->
  Map DataHash (Data era)
getDataMap :: forall era.
Era era =>
ScriptInfo era
-> Map ScriptHash (Script era) -> Map DataHash (Data era)
getDataMap (Map ScriptHash (TwoPhase3ArgInfo era)
scriptInfo3, Map ScriptHash (TwoPhase2ArgInfo era)
_) = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' Map DataHash (Data era)
-> ScriptHash -> Script era -> Map DataHash (Data era)
accum forall k a. Map k a
Map.empty
  where
    accum :: Map DataHash (Data era)
-> ScriptHash -> Script era -> Map DataHash (Data era)
accum Map DataHash (Data era)
ans ScriptHash
hsh Script era
_script =
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ScriptHash
hsh Map ScriptHash (TwoPhase3ArgInfo era)
scriptInfo3 of
        Maybe (TwoPhase3ArgInfo era)
Nothing -> Map DataHash (Data era)
ans
        Just (TwoPhase3ArgInfo Script era
_script ScriptHash
_hash Data
dat (Data, Natural, Natural)
_redeem Bool
_) ->
          forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Data -> DataHash
hashData Data
dat) (forall era. Era era => Data -> Data era
Data Data
dat) Map DataHash (Data era)
ans

instance MinGenTxout AlonzoEra where
  calcEraMinUTxO :: TxOut AlonzoEra -> PParams AlonzoEra -> Coin
calcEraMinUTxO TxOut AlonzoEra
txOut PParams AlonzoEra
pp = forall era. AlonzoEraTxOut era => TxOut era -> Integer
utxoEntrySize TxOut AlonzoEra
txOut forall t i. (Val t, Integral i) => i -> t -> t
<×> CoinPerWord -> Coin
unCoinPerWord (PParams AlonzoEra
pp forall s a. s -> Getting a s a -> a
^. forall era.
(AlonzoEraPParams era, ExactEra AlonzoEra era) =>
Lens' (PParams era) CoinPerWord
ppCoinsPerUTxOWordL)
  addValToTxOut :: Value AlonzoEra -> TxOut AlonzoEra -> TxOut AlonzoEra
addValToTxOut Value AlonzoEra
v (AlonzoTxOut Addr
a Value AlonzoEra
u StrictMaybe DataHash
_b) = forall era.
(Era era, Val (Value era), HasCallStack) =>
Addr -> Value era -> StrictMaybe DataHash -> AlonzoTxOut era
AlonzoTxOut Addr
a (Value AlonzoEra
v forall t. Val t => t -> t -> t
<+> Value AlonzoEra
u) (Addr -> StrictMaybe DataHash
dataFromAddr Addr
a)
  genEraTxOut :: GenEnv AlonzoEra
-> Gen (Value AlonzoEra) -> [Addr] -> Gen [TxOut AlonzoEra]
genEraTxOut GenEnv AlonzoEra
genv Gen (Value AlonzoEra)
genVal [Addr]
addrs = do
    [MaryValue]
values <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Addr]
addrs) Gen (Value AlonzoEra)
genVal
    let makeTxOut :: Addr -> MaryValue -> AlonzoTxOut AlonzoEra
makeTxOut Addr
addr MaryValue
val =
          case Addr
addr of
            Addr Network
_network (ScriptHashObj ScriptHash
shash) StakeReference
_stakeref ->
              forall era.
(Era era, Val (Value era), HasCallStack) =>
Addr -> Value era -> StrictMaybe DataHash -> AlonzoTxOut era
AlonzoTxOut Addr
addr MaryValue
val forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall era.
GenEnv era -> ScriptHash -> (Script era, StrictMaybe DataHash)
findPlutus GenEnv AlonzoEra
genv ScriptHash
shash
            Addr
_ -> forall era.
(Era era, Val (Value era), HasCallStack) =>
Addr -> Value era -> StrictMaybe DataHash -> AlonzoTxOut era
AlonzoTxOut Addr
addr MaryValue
val forall a. StrictMaybe a
SNothing
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Addr -> MaryValue -> AlonzoTxOut AlonzoEra
makeTxOut [Addr]
addrs [MaryValue]
values)

-- | If an Address is script address, we can find a potential data hash for it from
--   genEraTwoPhase3Arg, which contains all known 3 arg plutus scripts in the tests set.
-- If the script has is not in that map, then its data hash is SNothing.
dataFromAddr :: Addr -> StrictMaybe DataHash
dataFromAddr :: Addr -> StrictMaybe DataHash
dataFromAddr (Addr Network
_network (ScriptHashObj ScriptHash
shash) StakeReference
_stakeref) =
  let f :: TwoPhase3ArgInfo AlonzoEra -> Bool
f TwoPhase3ArgInfo AlonzoEra
info = ScriptHash
shash forall a. Eq a => a -> a -> Bool
== forall era. EraScript era => Script era -> ScriptHash
hashScript @AlonzoEra (forall era. TwoPhase3ArgInfo era -> Script era
getScript3 @AlonzoEra TwoPhase3ArgInfo AlonzoEra
info)
   in case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find TwoPhase3ArgInfo AlonzoEra -> Bool
f forall era. EraGen era => [TwoPhase3ArgInfo era]
genEraTwoPhase3Arg of
        Just TwoPhase3ArgInfo AlonzoEra
info -> forall a. a -> StrictMaybe a
SJust (Data -> DataHash
hashData (forall era. TwoPhase3ArgInfo era -> Data
getData3 TwoPhase3ArgInfo AlonzoEra
info))
        Maybe (TwoPhase3ArgInfo AlonzoEra)
Nothing -> forall a. StrictMaybe a
SNothing
dataFromAddr Addr
_ = forall a. StrictMaybe a
SNothing

-- | We can find the data associated with the data hashes in the TxOuts, since
--   genEraTwoPhase3Arg, which contains all known 3 arg plutus scripts stores the data.
dataMapFromTxOut ::
  [TxOut AlonzoEra] ->
  TxDats AlonzoEra ->
  TxDats AlonzoEra
dataMapFromTxOut :: [TxOut AlonzoEra] -> TxDats AlonzoEra -> TxDats AlonzoEra
dataMapFromTxOut [TxOut AlonzoEra]
txouts TxDats AlonzoEra
datahashmap = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Prelude.foldl forall {era} {era}.
(Val (Value era), Era era, Era era) =>
TxDats era -> AlonzoTxOut era -> TxDats era
accum TxDats AlonzoEra
datahashmap [TxOut AlonzoEra]
txouts
  where
    f :: DataHash -> TwoPhase3ArgInfo era -> Bool
f DataHash
dhash TwoPhase3ArgInfo era
info = Data -> DataHash
hashData (forall era. TwoPhase3ArgInfo era -> Data
getData3 TwoPhase3ArgInfo era
info) forall a. Eq a => a -> a -> Bool
== DataHash
dhash
    accum :: TxDats era -> AlonzoTxOut era -> TxDats era
accum !TxDats era
ans (AlonzoTxOut Addr
_ Value era
_ StrictMaybe DataHash
SNothing) = TxDats era
ans
    accum ans :: TxDats era
ans@(TxDats' Map DataHash (Data era)
m) (AlonzoTxOut Addr
_ Value era
_ (SJust DataHash
dhash)) =
      case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (forall {era}. DataHash -> TwoPhase3ArgInfo era -> Bool
f DataHash
dhash) (forall era. EraGen era => [TwoPhase3ArgInfo era]
genEraTwoPhase3Arg @AlonzoEra) of
        Just TwoPhase3ArgInfo AlonzoEra
info -> forall era. Era era => Map DataHash (Data era) -> TxDats era
TxDats (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert DataHash
dhash (forall era. Era era => Data -> Data era
Data (forall era. TwoPhase3ArgInfo era -> Data
getData3 TwoPhase3ArgInfo AlonzoEra
info)) Map DataHash (Data era)
m)
        Maybe (TwoPhase3ArgInfo AlonzoEra)
Nothing -> TxDats era
ans

addMaybeDataHashToTxOut :: TxOut AlonzoEra -> TxOut AlonzoEra
addMaybeDataHashToTxOut :: TxOut AlonzoEra -> TxOut AlonzoEra
addMaybeDataHashToTxOut (AlonzoTxOut Addr
addr Value AlonzoEra
val StrictMaybe DataHash
_) = forall era.
(Era era, Val (Value era), HasCallStack) =>
Addr -> Value era -> StrictMaybe DataHash -> AlonzoTxOut era
AlonzoTxOut Addr
addr Value AlonzoEra
val (Addr -> StrictMaybe DataHash
dataFromAddr Addr
addr)

someLeaf ::
  forall era.
  ( AllegraEraScript era
  , NativeScript era ~ Timelock era
  ) =>
  Proxy era ->
  KeyHash 'Witness ->
  AlonzoScript era
someLeaf :: forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
Proxy era -> KeyHash 'Witness -> AlonzoScript era
someLeaf Proxy era
_proxy KeyHash 'Witness
keyHash =
  let
    -- We use KeyHash as a source of entropy for initialization of an StdGen for
    -- generating slot and mode
    (Word64
s, StdGen
g) = forall g a. (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g)
uniformR (Word64
0, Word64
199) forall a b. (a -> b) -> a -> b
$ forall x. EncCBOR x => x -> StdGen
mkHashStdGen KeyHash 'Witness
keyHash
    slot :: SlotNo
slot = Word64 -> SlotNo
SlotNo Word64
s
    (Int
mode, StdGen
_) = forall g a. (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g)
uniformR (Int
0 :: Int, Int
2) StdGen
g -- mode==0 is a time leaf,  mode 1 or 2 is a signature leaf
   in
    case Int
mode of
      Int
0 ->
        forall era. Timelock era -> AlonzoScript era
TimelockScript forall a b. (a -> b) -> a -> b
$
          (forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> StrictSeq a
Seq.fromList) [forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeStart SlotNo
slot, forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeExpire SlotNo
slot]
      Int
_ -> forall era. Timelock era -> AlonzoScript era
TimelockScript forall a b. (a -> b) -> a -> b
$ forall era.
ShelleyEraScript era =>
KeyHash 'Witness -> NativeScript era
RequireSignature KeyHash 'Witness
keyHash

-- | given the "txscripts" field of the TxWits, compute the set of languages used in a transaction
langsUsed ::
  AlonzoEraScript era =>
  Map.Map ScriptHash (Script era) ->
  Set Language
langsUsed :: forall era.
AlonzoEraScript era =>
Map ScriptHash (Script era) -> Set Language
langsUsed Map ScriptHash (Script era)
hashScriptMap =
  forall a. Ord a => [a] -> Set a
Set.fromList
    [ forall era. AlonzoEraScript era => PlutusScript era -> Language
plutusScriptLanguage PlutusScript era
plutusScript
    | Script era
script <- forall k a. Map k a -> [a]
Map.elems Map ScriptHash (Script era)
hashScriptMap
    , Just PlutusScript era
plutusScript <- [forall era.
AlonzoEraScript era =>
Script era -> Maybe (PlutusScript era)
toPlutusScript Script era
script]
    ]