{-# 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 (
  -- export EraGen instance for AllegraEra and helpers shared with MaryEra
  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.BaseTypes (StrictMaybe (..))
import Cardano.Ledger.Binary (encCBOR, serialize')
import Cardano.Ledger.Coin (Coin)
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)

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

{------------------------------------------------------------------------------
 EraGen instance for AllegraEra - This instance makes it possible to run the
 Shelley property tests for AllegraEra

 This instance is layered on top of the ShelleyMA instances
 in Cardano.Ledger.ShelleyMA.Scripts:

 `type instance Script AllegraEra = Timelock AllegraEra`
 `instance ValidateScript (ShelleyMAEra ma c) where ...`
------------------------------------------------------------------------------}

instance ScriptClass AllegraEra where
  isKey :: Proxy AllegraEra -> Script AllegraEra -> Maybe (KeyHash 'Witness)
isKey Proxy AllegraEra
_ (RequireSignature KeyHash 'Witness
hk) = forall a. a -> Maybe a
Just KeyHash 'Witness
hk
  isKey Proxy AllegraEra
_ Script AllegraEra
_ = forall a. Maybe a
Nothing
  basescript :: Proxy AllegraEra -> KeyHash 'Witness -> Script AllegraEra
basescript Proxy AllegraEra
_proxy = forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
KeyHash 'Witness -> NativeScript era
someLeaf @AllegraEra
  quantify :: Proxy AllegraEra
-> Script AllegraEra -> Quantifier (Script AllegraEra)
quantify Proxy AllegraEra
_ = forall era.
AllegraEraScript era =>
NativeScript era -> Quantifier (NativeScript era)
quantifyTL
  unQuantify :: Proxy AllegraEra
-> Quantifier (Script AllegraEra) -> Script AllegraEra
unQuantify Proxy AllegraEra
_ = forall era.
AllegraEraScript era =>
Quantifier (NativeScript era) -> NativeScript era
unQuantifyTL

instance EraGen AllegraEra where
  genGenesisValue :: GenEnv AllegraEra -> Gen (Value AllegraEra)
genGenesisValue (GenEnv KeySpace AllegraEra
_keySpace ScriptSpace AllegraEra
_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
-> UTxO AllegraEra
-> PParams AllegraEra
-> SlotNo
-> Set TxIn
-> StrictSeq (TxOut AllegraEra)
-> StrictSeq (TxCert AllegraEra)
-> Withdrawals
-> Coin
-> StrictMaybe (Update AllegraEra)
-> StrictMaybe TxAuxDataHash
-> Gen (TxBody AllegraEra, [Script AllegraEra])
genEraTxBody GenEnv AllegraEra
_ge UTxO AllegraEra
_utxo PParams AllegraEra
_pparams = forall era.
AllegraEraTxBody era =>
SlotNo
-> Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> Gen (AllegraTxBody era, [Timelock era])
genTxBody
  genEraAuxiliaryData :: Constants -> Gen (StrictMaybe (TxAuxData AllegraEra))
genEraAuxiliaryData = forall era.
Arbitrary (TxAuxData era) =>
Constants -> Gen (StrictMaybe (TxAuxData era))
genAuxiliaryData
  updateEraTxBody :: UTxO AllegraEra
-> PParams AllegraEra
-> TxWits AllegraEra
-> TxBody AllegraEra
-> Coin
-> Set TxIn
-> TxOut AllegraEra
-> TxBody AllegraEra
updateEraTxBody UTxO AllegraEra
_utxo PParams AllegraEra
_pp TxWits AllegraEra
_wits TxBody AllegraEra
txBody Coin
fee Set TxIn
ins TxOut AllegraEra
out =
    TxBody AllegraEra
txBody
      forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Semigroup a => a -> a -> a
<> Set TxIn
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
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 -> Gen (PParamsUpdate AllegraEra)
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)
genEraPParams = forall era.
(EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) =>
Constants -> Gen (PParams era)
genPParams
  genEraTxWits :: (UTxO AllegraEra, TxBody AllegraEra, ScriptInfo AllegraEra)
-> Set (WitVKey 'Witness)
-> Map ScriptHash (Script AllegraEra)
-> TxWits AllegraEra
genEraTxWits (UTxO AllegraEra, TxBody AllegraEra, ScriptInfo AllegraEra)
_scriptinfo Set (WitVKey 'Witness)
setWitVKey Map ScriptHash (Script AllegraEra)
mapScriptWit = forall era.
EraScript era =>
Set (WitVKey 'Witness)
-> Map ScriptHash (Script era)
-> Set BootstrapWitness
-> ShelleyTxWits era
ShelleyTxWits Set (WitVKey 'Witness)
setWitVKey Map ScriptHash (Script AllegraEra)
mapScriptWit forall a. Monoid a => a
mempty
  constructTx :: TxBody AllegraEra
-> TxWits AllegraEra
-> StrictMaybe (TxAuxData AllegraEra)
-> Tx AllegraEra
constructTx = forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx

genTxBody ::
  AllegraEraTxBody era =>
  SlotNo ->
  Set.Set TxIn ->
  StrictSeq (TxOut era) ->
  StrictSeq (TxCert era) ->
  Withdrawals ->
  Coin ->
  StrictMaybe (Update era) ->
  StrictMaybe TxAuxDataHash ->
  Gen (AllegraTxBody era, [Timelock era])
genTxBody :: forall era.
AllegraEraTxBody era =>
SlotNo
-> Set TxIn
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> Gen (AllegraTxBody era, [Timelock era])
genTxBody SlotNo
slot Set TxIn
ins StrictSeq (TxOut era)
outs StrictSeq (TxCert era)
cert Withdrawals
wdrl Coin
fee StrictMaybe (Update era)
upd StrictMaybe TxAuxDataHash
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
-> StrictSeq (TxOut era)
-> StrictSeq (TxCert era)
-> Withdrawals
-> Coin
-> ValidityInterval
-> StrictMaybe (Update era)
-> StrictMaybe TxAuxDataHash
-> AllegraTxBody era
AllegraTxBody
        Set TxIn
ins
        StrictSeq (TxOut era)
outs
        StrictSeq (TxCert era)
cert
        Withdrawals
wdrl
        Coin
fee
        ValidityInterval
validityInterval
        StrictMaybe (Update era)
upd
        StrictMaybe TxAuxDataHash
ad
    , [] -- Allegra does not need any additional script witnesses
    )

instance MinGenTxout AllegraEra where
  calcEraMinUTxO :: TxOut AllegraEra -> PParams AllegraEra -> Coin
calcEraMinUTxO TxOut AllegraEra
_txout PParams AllegraEra
pp = PParams AllegraEra
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 -> TxOut AllegraEra -> TxOut AllegraEra
addValToTxOut Value AllegraEra
v (ShelleyTxOut Addr
a Value AllegraEra
u) = forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
a (Value AllegraEra
v forall t. Val t => t -> t -> t
<+> Value AllegraEra
u)
  genEraTxOut :: GenEnv AllegraEra
-> Gen (Value AllegraEra) -> [Addr] -> Gen [TxOut AllegraEra]
genEraTxOut GenEnv AllegraEra
_genenv Gen (Value AllegraEra)
genVal [Addr]
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]
addrs) Gen (Value AllegraEra)
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 -> Value era -> TxOut era
mkBasicTxOut [Addr]
addrs [Coin]
values)

{------------------------------------------------------------------------------
  ShelleyMA helpers, shared by Allegra and Mary
------------------------------------------------------------------------------}

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)
    ]

-- | Generates a trivial validity interval that is valid for the current slot.
--
-- Note: the validity interval must be a subset of all timelock
-- script intervals that apply to the transaction. This depends on
-- which generated scripts are actually required to validate the transaction
-- (which is itself not always deterministic, e.g. 'RequireMOf n scripts').
--
-- A more sophisticated generator would compute which set of scripts
-- would validate the transaction, and from that compute a minimal
-- ValidityInterval that fits into all timelock slot ranges.
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)

-- | Generate some Leaf Timelock (i.e. a Signature or TimeStart or TimeExpire).
--
-- Because we don't know how these "leaf scripts" will be situated in larger scripts
-- (e.g. the script generated here might form part of a 'RequireAll' or 'RequireMOf' script)
-- we must make sure that all timelocks generated here are valid for all slots.
--
-- To achieve this we arrange the timelock scripts like so:
--  RequireAnyOf [
--     RequireAllOf [RequireTimeExpire k, RequireSignature x],
--     RequireAllOf [RequireTimeStart k, RequireSignature x]
--  ]
-- where k is arbitrary. This means that regardless of slot, there will be a
-- valid sub-branch of script.
someLeaf ::
  forall era.
  (AllegraEraScript era, NativeScript era ~ Timelock era) =>
  KeyHash 'Witness ->
  NativeScript era
someLeaf :: forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
KeyHash 'Witness -> NativeScript era
someLeaf KeyHash 'Witness
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
x))) Int
200
   in forall era.
AllegraEraScript era =>
[Int] -> [NativeScript era] -> NativeScript era
partition @era [Int
n] [forall era.
ShelleyEraScript era =>
KeyHash 'Witness -> NativeScript era
RequireSignature KeyHash 'Witness
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