{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Test.Cardano.Ledger.AllegraEraGen (
quantifyTL,
unQuantifyTL,
someLeaf,
genValidityInterval,
)
where
import Cardano.Ledger.Allegra (AllegraEra)
import Cardano.Ledger.Allegra.Core
import Cardano.Ledger.Allegra.Scripts (
AllegraEraScript,
Timelock (..),
pattern RequireTimeExpire,
pattern RequireTimeStart,
)
import Cardano.Ledger.Allegra.TxBody (AllegraTxBody (..))
import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash)
import Cardano.Ledger.BaseTypes (StrictMaybe (..))
import Cardano.Ledger.Binary (encCBOR, serialize')
import Cardano.Ledger.Coin (Coin)
import qualified Cardano.Ledger.Crypto as CryptoClass
import Cardano.Ledger.Keys (KeyHash)
import Cardano.Ledger.Shelley.API (KeyRole (Witness))
import Cardano.Ledger.Shelley.PParams (Update)
import Cardano.Ledger.Shelley.Scripts (
pattern RequireAllOf,
pattern RequireAnyOf,
pattern RequireMOf,
pattern RequireSignature,
)
import Cardano.Ledger.Shelley.Tx (pattern ShelleyTx)
import Cardano.Ledger.Shelley.TxOut (ShelleyTxOut (..))
import Cardano.Ledger.Shelley.TxWits (pattern ShelleyTxWits)
import Cardano.Ledger.TxIn (TxIn)
import Cardano.Ledger.Val ((<+>))
import Cardano.Slotting.Slot (SlotNo (SlotNo))
import Control.Monad (replicateM)
import Data.Hashable (hash)
import Data.Sequence.Strict (StrictSeq (..), fromList)
import qualified Data.Set as Set
import Lens.Micro
import Test.Cardano.Ledger.Allegra.Arbitrary ()
import Test.Cardano.Ledger.Shelley.Constants (Constants (..))
import Test.Cardano.Ledger.Shelley.Generator.Core (GenEnv (..), genCoin)
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 (genPParams, genShelleyPParamsUpdate)
import Test.Cardano.Ledger.ShelleyMA.Serialisation.Generators ()
import Test.QuickCheck (Arbitrary, Gen, arbitrary, frequency)
instance CryptoClass.Crypto c => ScriptClass (AllegraEra c) where
isKey :: Proxy (AllegraEra c)
-> Script (AllegraEra c)
-> Maybe (KeyHash 'Witness (EraCrypto (AllegraEra c)))
isKey Proxy (AllegraEra c)
_ (RequireSignature KeyHash 'Witness (EraCrypto (AllegraEra c))
hk) = forall a. a -> Maybe a
Just KeyHash 'Witness (EraCrypto (AllegraEra c))
hk
isKey Proxy (AllegraEra c)
_ Script (AllegraEra c)
_ = forall a. Maybe a
Nothing
basescript :: Proxy (AllegraEra c)
-> KeyHash 'Witness (EraCrypto (AllegraEra c))
-> Script (AllegraEra c)
basescript Proxy (AllegraEra c)
_proxy = forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
KeyHash 'Witness (EraCrypto era) -> NativeScript era
someLeaf @(AllegraEra c)
quantify :: Proxy (AllegraEra c)
-> Script (AllegraEra c) -> Quantifier (Script (AllegraEra c))
quantify Proxy (AllegraEra c)
_ = forall era.
AllegraEraScript era =>
NativeScript era -> Quantifier (NativeScript era)
quantifyTL
unQuantify :: Proxy (AllegraEra c)
-> Quantifier (Script (AllegraEra c)) -> Script (AllegraEra c)
unQuantify Proxy (AllegraEra c)
_ = forall era.
AllegraEraScript era =>
Quantifier (NativeScript era) -> NativeScript era
unQuantifyTL
instance CryptoClass.Crypto c => EraGen (AllegraEra c) where
genGenesisValue :: GenEnv (AllegraEra c) -> Gen (Value (AllegraEra c))
genGenesisValue (GenEnv KeySpace (AllegraEra c)
_keySpace ScriptSpace (AllegraEra 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 (AllegraEra c)
-> UTxO (AllegraEra c)
-> PParams (AllegraEra c)
-> SlotNo
-> Set (TxIn (EraCrypto (AllegraEra c)))
-> StrictSeq (TxOut (AllegraEra c))
-> StrictSeq (TxCert (AllegraEra c))
-> Withdrawals (EraCrypto (AllegraEra c))
-> Coin
-> StrictMaybe (Update (AllegraEra c))
-> StrictMaybe (AuxiliaryDataHash (EraCrypto (AllegraEra c)))
-> Gen (TxBody (AllegraEra c), [Script (AllegraEra c)])
genEraTxBody GenEnv (AllegraEra c)
_ge UTxO (AllegraEra c)
_utxo PParams (AllegraEra c)
_pparams = forall era.
AllegraEraTxBody era =>
SlotNo
-> Set (TxIn (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> Gen (AllegraTxBody era, [Timelock era])
genTxBody
genEraAuxiliaryData :: Constants -> Gen (StrictMaybe (TxAuxData (AllegraEra c)))
genEraAuxiliaryData = forall era.
Arbitrary (TxAuxData era) =>
Constants -> Gen (StrictMaybe (TxAuxData era))
genAuxiliaryData
updateEraTxBody :: UTxO (AllegraEra c)
-> PParams (AllegraEra c)
-> TxWits (AllegraEra c)
-> TxBody (AllegraEra c)
-> Coin
-> Set (TxIn (EraCrypto (AllegraEra c)))
-> TxOut (AllegraEra c)
-> TxBody (AllegraEra c)
updateEraTxBody UTxO (AllegraEra c)
_utxo PParams (AllegraEra c)
_pp TxWits (AllegraEra c)
_wits TxBody (AllegraEra c)
txBody Coin
fee Set (TxIn (EraCrypto (AllegraEra c)))
ins TxOut (AllegraEra c)
out =
TxBody (AllegraEra c)
txBody
forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Semigroup a => a -> a -> a
<> Set (TxIn (EraCrypto (AllegraEra c)))
ins)
forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. StrictSeq a -> a -> StrictSeq a
:|> TxOut (AllegraEra c)
out)
forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
fee
genEraPParamsUpdate :: Constants
-> PParams (AllegraEra c) -> Gen (PParamsUpdate (AllegraEra c))
genEraPParamsUpdate = forall era.
(ProtVerAtMost era 4, ProtVerAtMost era 6, ProtVerAtMost era 8,
EraPParams era) =>
Constants -> PParams era -> Gen (PParamsUpdate era)
genShelleyPParamsUpdate
genEraPParams :: Constants -> Gen (PParams (AllegraEra c))
genEraPParams = forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
Constants -> Gen (PParams era)
genPParams
genEraTxWits :: (UTxO (AllegraEra c), TxBody (AllegraEra c),
ScriptInfo (AllegraEra c))
-> Set (WitVKey 'Witness (EraCrypto (AllegraEra c)))
-> Map
(ScriptHash (EraCrypto (AllegraEra c))) (Script (AllegraEra c))
-> TxWits (AllegraEra c)
genEraTxWits (UTxO (AllegraEra c), TxBody (AllegraEra c),
ScriptInfo (AllegraEra c))
_scriptinfo Set (WitVKey 'Witness (EraCrypto (AllegraEra c)))
setWitVKey Map (ScriptHash (EraCrypto (AllegraEra c))) (Script (AllegraEra 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 (AllegraEra c)))
setWitVKey Map (ScriptHash (EraCrypto (AllegraEra c))) (Script (AllegraEra c))
mapScriptWit forall a. Monoid a => a
mempty
constructTx :: TxBody (AllegraEra c)
-> TxWits (AllegraEra c)
-> StrictMaybe (TxAuxData (AllegraEra c))
-> Tx (AllegraEra c)
constructTx = forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx
genTxBody ::
AllegraEraTxBody era =>
SlotNo ->
Set.Set (TxIn (EraCrypto era)) ->
StrictSeq (TxOut era) ->
StrictSeq (TxCert era) ->
Withdrawals (EraCrypto era) ->
Coin ->
StrictMaybe (Update era) ->
StrictMaybe (AuxiliaryDataHash (EraCrypto era)) ->
Gen (AllegraTxBody era, [Timelock era])
genTxBody :: forall era.
AllegraEraTxBody era =>
SlotNo
-> Set (TxIn (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> Gen (AllegraTxBody era, [Timelock era])
genTxBody SlotNo
slot Set (TxIn (EraCrypto era))
ins StrictSeq (TxOut era)
outs StrictSeq (TxCert era)
cert Withdrawals (EraCrypto era)
wdrl Coin
fee StrictMaybe (Update era)
upd StrictMaybe (AuxiliaryDataHash (EraCrypto era))
ad = do
ValidityInterval
validityInterval <- SlotNo -> Gen ValidityInterval
genValidityInterval SlotNo
slot
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( forall era.
(EraTxOut era, EraTxCert era) =>
Set (TxIn (EraCrypto era))
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals (EraCrypto era)
-> Coin
-> ValidityInterval
-> StrictMaybe (Update era)
-> StrictMaybe (AuxiliaryDataHash (EraCrypto era))
-> AllegraTxBody era
AllegraTxBody
Set (TxIn (EraCrypto era))
ins
StrictSeq (TxOut era)
outs
StrictSeq (TxCert era)
cert
Withdrawals (EraCrypto era)
wdrl
Coin
fee
ValidityInterval
validityInterval
StrictMaybe (Update era)
upd
StrictMaybe (AuxiliaryDataHash (EraCrypto era))
ad
, []
)
instance CryptoClass.Crypto c => MinGenTxout (AllegraEra c) where
calcEraMinUTxO :: TxOut (AllegraEra c) -> PParams (AllegraEra c) -> Coin
calcEraMinUTxO TxOut (AllegraEra c)
_txout PParams (AllegraEra c)
pp = PParams (AllegraEra c)
pp forall s a. s -> Getting a s a -> a
^. forall era.
(EraPParams era, ProtVerAtMost era 4) =>
Lens' (PParams era) Coin
ppMinUTxOValueL
addValToTxOut :: Value (AllegraEra c)
-> TxOut (AllegraEra c) -> TxOut (AllegraEra c)
addValToTxOut Value (AllegraEra c)
v (ShelleyTxOut Addr (EraCrypto (AllegraEra c))
a Value (AllegraEra c)
u) = forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr (EraCrypto era) -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr (EraCrypto (AllegraEra c))
a (Value (AllegraEra c)
v forall t. Val t => t -> t -> t
<+> Value (AllegraEra c)
u)
genEraTxOut :: GenEnv (AllegraEra c)
-> Gen (Value (AllegraEra c))
-> [Addr (EraCrypto (AllegraEra c))]
-> Gen [TxOut (AllegraEra c)]
genEraTxOut GenEnv (AllegraEra c)
_genenv Gen (Value (AllegraEra c))
genVal [Addr (EraCrypto (AllegraEra 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 (AllegraEra c))]
addrs) Gen (Value (AllegraEra 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 (AllegraEra c))]
addrs [Coin]
values)
quantifyTL ::
AllegraEraScript era =>
NativeScript era ->
Quantifier (NativeScript era)
quantifyTL :: forall era.
AllegraEraScript era =>
NativeScript era -> Quantifier (NativeScript era)
quantifyTL (RequireAllOf StrictSeq (NativeScript era)
xs) = forall t. [t] -> Quantifier t
AllOf (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [] StrictSeq (NativeScript era)
xs)
quantifyTL (RequireAnyOf StrictSeq (NativeScript era)
xs) = forall t. [t] -> Quantifier t
AnyOf (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [] StrictSeq (NativeScript era)
xs)
quantifyTL (RequireMOf Int
n StrictSeq (NativeScript era)
xs) = forall t. Int -> [t] -> Quantifier t
MOf Int
n (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [] StrictSeq (NativeScript era)
xs)
quantifyTL NativeScript era
t = forall t. t -> Quantifier t
Leaf NativeScript era
t
unQuantifyTL :: AllegraEraScript era => Quantifier (NativeScript era) -> NativeScript era
unQuantifyTL :: forall era.
AllegraEraScript era =>
Quantifier (NativeScript era) -> NativeScript era
unQuantifyTL (AllOf [NativeScript era]
xs) = forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf (forall a. [a] -> StrictSeq a
fromList [NativeScript era]
xs)
unQuantifyTL (AnyOf [NativeScript era]
xs) = forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf (forall a. [a] -> StrictSeq a
fromList [NativeScript era]
xs)
unQuantifyTL (MOf Int
n [NativeScript era]
xs) = forall era.
ShelleyEraScript era =>
Int -> StrictSeq (NativeScript era) -> NativeScript era
RequireMOf Int
n (forall a. [a] -> StrictSeq a
fromList [NativeScript era]
xs)
unQuantifyTL (Leaf NativeScript era
t) = NativeScript era
t
genAuxiliaryData ::
Arbitrary (TxAuxData era) =>
Constants ->
Gen (StrictMaybe (TxAuxData era))
genAuxiliaryData :: forall era.
Arbitrary (TxAuxData era) =>
Constants -> Gen (StrictMaybe (TxAuxData era))
genAuxiliaryData Constants {Int
frequencyTxWithMetadata :: Constants -> Int
frequencyTxWithMetadata :: Int
frequencyTxWithMetadata} =
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
[ (Int
frequencyTxWithMetadata, forall a. a -> StrictMaybe a
SJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary)
, (Int
100 forall a. Num a => a -> a -> a
- Int
frequencyTxWithMetadata, forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. StrictMaybe a
SNothing)
]
genValidityInterval :: SlotNo -> Gen ValidityInterval
genValidityInterval :: SlotNo -> Gen ValidityInterval
genValidityInterval cs :: SlotNo
cs@(SlotNo Word64
currentSlot) =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval
(forall a. a -> StrictMaybe a
SJust SlotNo
cs)
(forall a. a -> StrictMaybe a
SJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> SlotNo
SlotNo forall a b. (a -> b) -> a -> b
$ Word64
currentSlot forall a. Num a => a -> a -> a
+ Word64
1)
someLeaf ::
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
KeyHash 'Witness (EraCrypto era) ->
NativeScript era
someLeaf :: forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
KeyHash 'Witness (EraCrypto era) -> NativeScript era
someLeaf KeyHash 'Witness (EraCrypto era)
x =
let n :: Int
n = forall a. Integral a => a -> a -> a
mod (forall a. Hashable a => a -> Int
hash (forall a. EncCBOR a => Version -> a -> ByteString
serialize' (forall era. Era era => Version
eraProtVerLow @era) (forall a. EncCBOR a => a -> Encoding
encCBOR KeyHash 'Witness (EraCrypto era)
x))) Int
200
in forall era.
AllegraEraScript era =>
[Int] -> [NativeScript era] -> NativeScript era
partition @era [Int
n] [forall era.
ShelleyEraScript era =>
KeyHash 'Witness (EraCrypto era) -> NativeScript era
RequireSignature KeyHash 'Witness (EraCrypto era)
x]
partition ::
forall era.
AllegraEraScript era =>
[Int] ->
[NativeScript era] ->
NativeScript era
partition :: forall era.
AllegraEraScript era =>
[Int] -> [NativeScript era] -> NativeScript era
partition [Int]
splits [NativeScript era]
scripts =
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
fromList forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {era}.
ShelleyEraScript era =>
NativeScript era -> NativeScript era -> NativeScript era
pair (forall era. AllegraEraScript era => [Int] -> [NativeScript era]
intervals @era [Int]
splits) (forall a. [a] -> [a]
cycle [NativeScript era]
scripts)
where
pair :: NativeScript era -> NativeScript era -> NativeScript era
pair NativeScript era
a NativeScript era
b = forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf forall a b. (a -> b) -> a -> b
$ forall a. [a] -> StrictSeq a
fromList [NativeScript era
a, NativeScript era
b]
intervals ::
forall era.
AllegraEraScript era =>
[Int] ->
[NativeScript era]
intervals :: forall era. AllegraEraScript era => [Int] -> [NativeScript era]
intervals [Int]
xs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {era}.
AllegraEraScript era =>
Maybe SlotNo -> Maybe SlotNo -> NativeScript era
mkInterval [Maybe SlotNo]
padded (forall a. Int -> [a] -> [a]
drop Int
1 [Maybe SlotNo]
padded)
where
padded :: [Maybe SlotNo]
padded = forall a. Maybe a
Nothing forall a. a -> [a] -> [a]
: (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> SlotNo
SlotNo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
xs) forall a. [a] -> [a] -> [a]
++ [forall a. Maybe a
Nothing]
start :: Maybe SlotNo -> [NativeScript era]
start Maybe SlotNo
Nothing = []
start (Just SlotNo
x) = [forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeStart SlotNo
x]
end :: Maybe SlotNo -> [NativeScript era]
end Maybe SlotNo
Nothing = []
end (Just SlotNo
x) = [forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeExpire SlotNo
x]
mkInterval :: Maybe SlotNo -> Maybe SlotNo -> NativeScript era
mkInterval Maybe SlotNo
s Maybe SlotNo
e = forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> StrictSeq a
fromList forall a b. (a -> b) -> a -> b
$ forall {era}.
AllegraEraScript era =>
Maybe SlotNo -> [NativeScript era]
start Maybe SlotNo
s forall a. [a] -> [a] -> [a]
++ forall {era}.
AllegraEraScript era =>
Maybe SlotNo -> [NativeScript era]
end Maybe SlotNo
e