{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Test.Cardano.Ledger.Shelley.MultiSigExamples (
  applyTxWithScript,
  aliceOnly,
  bobOnly,
  aliceAndBob,
  aliceOrBob,
  aliceAndBobOrCarl,
  aliceAndBobOrCarlAndDaria,
  aliceAndBobOrCarlOrDaria,
) where

import qualified Cardano.Crypto.Hash as Hash
import Cardano.Ledger.Address (Addr (Addr))
import Cardano.Ledger.BaseTypes (
  Network (..),
  StrictMaybe (..),
  maybeToStrictMaybe,
  mkTxIxPartial,
 )
import Cardano.Ledger.Coin
import Cardano.Ledger.Credential (
  pattern KeyHashObj,
  pattern ScriptHashObj,
  pattern StakeRefBase,
 )
import Cardano.Ledger.Keys (asWitness)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (
  LedgerState (..),
  UTxOState,
  genesisState,
 )
import Cardano.Ledger.Shelley.Rules (ShelleyUTXOW, UtxoEnv (..))
import Cardano.Ledger.Shelley.Scripts (
  MultiSig,
  ShelleyEraScript,
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  pattern RequireSignature,
 )
import Cardano.Ledger.Shelley.State
import Cardano.Ledger.Shelley.TxAuxData (ShelleyTxAuxData)
import Cardano.Ledger.Shelley.TxBody (TxBody (ShelleyTxBody))
import Cardano.Ledger.Shelley.TxWits (ShelleyTxWits (..))
import Cardano.Ledger.Slot (SlotNo (..))
import Cardano.Ledger.TxIn (TxId, TxIn (..))
import qualified Cardano.Ledger.Val as Val
import Control.State.Transition
import Data.Default (Default (def))
import Data.Foldable (fold)
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map (empty, fromList)
import Data.Sequence.Strict (StrictSeq (..))
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set (fromList)
import Lens.Micro
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), mkWitnessesVKey)
import qualified Test.Cardano.Ledger.Shelley.Examples.Cast as Cast
import Test.Cardano.Ledger.Shelley.Generator.Core (genesisCoins)
import Test.Cardano.Ledger.Shelley.Generator.EraGen (genesisId)
import Test.Cardano.Ledger.Shelley.Generator.ShelleyEraGen ()
import Test.Cardano.Ledger.Shelley.Utils

-- Multi-Signature tests

-- This compile-time test asserts that the script hash and key hash use the
-- same hash size and indeed hash function. We do this by checking we can
-- type-check the following code that converts between them by using the hash
-- casting function which changes what the hash is of, without changing the
-- hashing algorithm.
--
_assertScriptHashSizeMatchesAddrHashSize :: ScriptHash -> KeyHash r
_assertScriptHashSizeMatchesAddrHashSize :: forall (r :: KeyRole). ScriptHash -> KeyHash r
_assertScriptHashSizeMatchesAddrHashSize (ScriptHash Hash ADDRHASH EraIndependentScript
h) = Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash r
forall (r :: KeyRole).
Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash r
KeyHash (Hash ADDRHASH EraIndependentScript
-> Hash ADDRHASH (VerKeyDSIGN DSIGN)
forall h a b. Hash h a -> Hash h b
Hash.castHash Hash ADDRHASH EraIndependentScript
h)

-- Multi-signature scripts
singleKeyOnly :: ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly :: forall era. ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly (Addr Network
_ (KeyHashObj KeyHash Payment
pk) StakeReference
_) = KeyHash Witness -> NativeScript era
forall era.
ShelleyEraScript era =>
KeyHash Witness -> NativeScript era
RequireSignature (KeyHash Witness -> NativeScript era)
-> KeyHash Witness -> NativeScript era
forall a b. (a -> b) -> a -> b
$ KeyHash Payment -> KeyHash Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a Witness
asWitness KeyHash Payment
pk
singleKeyOnly Addr
_ = [Char] -> NativeScript era
forall a. HasCallStack => [Char] -> a
error [Char]
"use VKey address"

aliceOnly :: ShelleyEraScript era => NativeScript era
aliceOnly :: forall era. ShelleyEraScript era => NativeScript era
aliceOnly = Addr -> NativeScript era
forall era. ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly Addr
Cast.aliceAddr

bobOnly :: ShelleyEraScript era => NativeScript era
bobOnly :: forall era. ShelleyEraScript era => NativeScript era
bobOnly = Addr -> NativeScript era
forall era. ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly Addr
Cast.bobAddr

aliceOrBob :: ShelleyEraScript era => NativeScript era
aliceOrBob :: forall era. ShelleyEraScript era => NativeScript era
aliceOrBob = StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf ([NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [NativeScript era
forall era. ShelleyEraScript era => NativeScript era
aliceOnly, Addr -> NativeScript era
forall era. ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly Addr
Cast.bobAddr])

aliceAndBob :: ShelleyEraScript era => NativeScript era
aliceAndBob :: forall era. ShelleyEraScript era => NativeScript era
aliceAndBob = StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf ([NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [NativeScript era
forall era. ShelleyEraScript era => NativeScript era
aliceOnly, Addr -> NativeScript era
forall era. ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly Addr
Cast.bobAddr])

aliceAndBobOrCarl :: ShelleyEraScript era => NativeScript era
aliceAndBobOrCarl :: forall era. ShelleyEraScript era => NativeScript era
aliceAndBobOrCarl = Int -> StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
Int -> StrictSeq (NativeScript era) -> NativeScript era
RequireMOf Int
1 ([NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [NativeScript era
forall era. ShelleyEraScript era => NativeScript era
aliceAndBob, Addr -> NativeScript era
forall era. ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly Addr
Cast.carlAddr])

aliceAndBobOrCarlAndDaria :: ShelleyEraScript era => NativeScript era
aliceAndBobOrCarlAndDaria :: forall era. ShelleyEraScript era => NativeScript era
aliceAndBobOrCarlAndDaria =
  StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf (StrictSeq (NativeScript era) -> NativeScript era)
-> StrictSeq (NativeScript era) -> NativeScript era
forall a b. (a -> b) -> a -> b
$
    [NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList
      [ NativeScript era
forall era. ShelleyEraScript era => NativeScript era
aliceAndBob
      , StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf ([NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [Addr -> NativeScript era
forall era. ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly Addr
Cast.carlAddr, Addr -> NativeScript era
forall era. ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly Addr
Cast.dariaAddr])
      ]

aliceAndBobOrCarlOrDaria ::
  ShelleyEraScript era =>
  NativeScript era
aliceAndBobOrCarlOrDaria :: forall era. ShelleyEraScript era => NativeScript era
aliceAndBobOrCarlOrDaria =
  Int -> StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
Int -> StrictSeq (NativeScript era) -> NativeScript era
RequireMOf
    Int
1
    (StrictSeq (NativeScript era) -> NativeScript era)
-> StrictSeq (NativeScript era) -> NativeScript era
forall a b. (a -> b) -> a -> b
$ [NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList
      [ NativeScript era
forall era. ShelleyEraScript era => NativeScript era
aliceAndBob
      , StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf ([NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [Addr -> NativeScript era
forall era. ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly Addr
Cast.carlAddr, Addr -> NativeScript era
forall era. ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly Addr
Cast.dariaAddr])
      ]

initTxBody ::
  [(Addr, Value ShelleyEra)] ->
  TxBody TopTx ShelleyEra
initTxBody :: [(Addr, Value ShelleyEra)] -> TxBody TopTx ShelleyEra
initTxBody [(Addr, Value ShelleyEra)]
addrs =
  Set TxIn
-> StrictSeq (TxOut ShelleyEra)
-> StrictSeq (TxCert ShelleyEra)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update ShelleyEra)
-> StrictMaybe TxAuxDataHash
-> TxBody TopTx ShelleyEra
ShelleyTxBody
    ([TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList [TxId -> TxIx -> TxIn
TxIn TxId
genesisId TxIx
forall a. Bounded a => a
minBound, TxId -> TxIx -> TxIn
TxIn TxId
genesisId (HasCallStack => Integer -> TxIx
Integer -> TxIx
mkTxIxPartial Integer
1)])
    ([TxOut ShelleyEra] -> StrictSeq (TxOut ShelleyEra)
forall a. [a] -> StrictSeq a
StrictSeq.fromList ([TxOut ShelleyEra] -> StrictSeq (TxOut ShelleyEra))
-> [TxOut ShelleyEra] -> StrictSeq (TxOut ShelleyEra)
forall a b. (a -> b) -> a -> b
$ ((Addr, Value ShelleyEra) -> ShelleyTxOut ShelleyEra)
-> [(Addr, Value ShelleyEra)] -> [ShelleyTxOut ShelleyEra]
forall a b. (a -> b) -> [a] -> [b]
map ((Addr -> Value ShelleyEra -> ShelleyTxOut ShelleyEra)
-> (Addr, Value ShelleyEra) -> ShelleyTxOut ShelleyEra
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Addr -> Value ShelleyEra -> TxOut ShelleyEra
Addr -> Value ShelleyEra -> ShelleyTxOut ShelleyEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut) [(Addr, Value ShelleyEra)]
addrs)
    StrictSeq (TxCert ShelleyEra)
StrictSeq (ShelleyTxCert ShelleyEra)
forall a. StrictSeq a
Empty
    (Map RewardAccount Coin -> Withdrawals
Withdrawals Map RewardAccount Coin
forall k a. Map k a
Map.empty)
    (Integer -> Coin
Coin Integer
0)
    (Word64 -> SlotNo
SlotNo Word64
0)
    StrictMaybe (Update ShelleyEra)
forall a. StrictMaybe a
SNothing
    StrictMaybe TxAuxDataHash
forall a. StrictMaybe a
SNothing

makeTxBody ::
  [TxIn] ->
  [(Addr, Value ShelleyEra)] ->
  Withdrawals ->
  TxBody TopTx ShelleyEra
makeTxBody :: [TxIn]
-> [(Addr, Value ShelleyEra)]
-> Withdrawals
-> TxBody TopTx ShelleyEra
makeTxBody [TxIn]
inp [(Addr, Value ShelleyEra)]
addrCs Withdrawals
wdrl =
  Set TxIn
-> StrictSeq (TxOut ShelleyEra)
-> StrictSeq (TxCert ShelleyEra)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update ShelleyEra)
-> StrictMaybe TxAuxDataHash
-> TxBody TopTx ShelleyEra
ShelleyTxBody
    ([TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList [TxIn]
inp)
    ([ShelleyTxOut ShelleyEra] -> StrictSeq (ShelleyTxOut ShelleyEra)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [(Addr -> Coin -> ShelleyTxOut ShelleyEra)
-> (Addr, Coin) -> ShelleyTxOut ShelleyEra
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Addr -> Value ShelleyEra -> TxOut ShelleyEra
Addr -> Coin -> ShelleyTxOut ShelleyEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut (Addr, Coin)
addrC | (Addr, Coin)
addrC <- [(Addr, Value ShelleyEra)]
[(Addr, Coin)]
addrCs])
    StrictSeq (TxCert ShelleyEra)
StrictSeq (ShelleyTxCert ShelleyEra)
forall a. StrictSeq a
Empty
    Withdrawals
wdrl
    (Integer -> Coin
Coin Integer
0)
    (Word64 -> SlotNo
SlotNo Word64
10)
    StrictMaybe (Update ShelleyEra)
forall a. StrictMaybe a
SNothing
    StrictMaybe TxAuxDataHash
forall a. StrictMaybe a
SNothing

makeTx ::
  TxBody TopTx ShelleyEra ->
  [KeyPair Witness] ->
  Map ScriptHash (MultiSig ShelleyEra) ->
  Maybe (ShelleyTxAuxData ShelleyEra) ->
  Tx TopTx ShelleyEra
makeTx :: TxBody TopTx ShelleyEra
-> [KeyPair Witness]
-> Map ScriptHash (MultiSig ShelleyEra)
-> Maybe (ShelleyTxAuxData ShelleyEra)
-> Tx TopTx ShelleyEra
makeTx TxBody TopTx ShelleyEra
txBody [KeyPair Witness]
keyPairs Map ScriptHash (MultiSig ShelleyEra)
msigs Maybe (ShelleyTxAuxData ShelleyEra)
auxData =
  TxBody TopTx ShelleyEra -> Tx TopTx ShelleyEra
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l ShelleyEra -> Tx l ShelleyEra
mkBasicTx TxBody TopTx ShelleyEra
txBody
    Tx TopTx ShelleyEra
-> (Tx TopTx ShelleyEra -> Tx TopTx ShelleyEra)
-> Tx TopTx ShelleyEra
forall a b. a -> (a -> b) -> b
& (TxWits ShelleyEra -> Identity (TxWits ShelleyEra))
-> Tx TopTx ShelleyEra -> Identity (Tx TopTx ShelleyEra)
(ShelleyTxWits ShelleyEra -> Identity (ShelleyTxWits ShelleyEra))
-> Tx TopTx ShelleyEra -> Identity (Tx TopTx ShelleyEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l ShelleyEra) (TxWits ShelleyEra)
witsTxL ((ShelleyTxWits ShelleyEra -> Identity (ShelleyTxWits ShelleyEra))
 -> Tx TopTx ShelleyEra -> Identity (Tx TopTx ShelleyEra))
-> ShelleyTxWits ShelleyEra
-> Tx TopTx ShelleyEra
-> Tx TopTx ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ShelleyTxWits ShelleyEra
txWits
    Tx TopTx ShelleyEra
-> (Tx TopTx ShelleyEra -> Tx TopTx ShelleyEra)
-> Tx TopTx ShelleyEra
forall a b. a -> (a -> b) -> b
& (StrictMaybe (TxAuxData ShelleyEra)
 -> Identity (StrictMaybe (TxAuxData ShelleyEra)))
-> Tx TopTx ShelleyEra -> Identity (Tx TopTx ShelleyEra)
(StrictMaybe (ShelleyTxAuxData ShelleyEra)
 -> Identity (StrictMaybe (ShelleyTxAuxData ShelleyEra)))
-> Tx TopTx ShelleyEra -> Identity (Tx TopTx ShelleyEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
forall (l :: TxLevel).
Lens' (Tx l ShelleyEra) (StrictMaybe (TxAuxData ShelleyEra))
auxDataTxL ((StrictMaybe (ShelleyTxAuxData ShelleyEra)
  -> Identity (StrictMaybe (ShelleyTxAuxData ShelleyEra)))
 -> Tx TopTx ShelleyEra -> Identity (Tx TopTx ShelleyEra))
-> StrictMaybe (ShelleyTxAuxData ShelleyEra)
-> Tx TopTx ShelleyEra
-> Tx TopTx ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe (ShelleyTxAuxData ShelleyEra)
-> StrictMaybe (ShelleyTxAuxData ShelleyEra)
forall a. Maybe a -> StrictMaybe a
maybeToStrictMaybe Maybe (ShelleyTxAuxData ShelleyEra)
auxData
  where
    txWits :: ShelleyTxWits ShelleyEra
    txWits :: ShelleyTxWits ShelleyEra
txWits =
      TxWits ShelleyEra
forall era. EraTxWits era => TxWits era
mkBasicTxWits
        TxWits ShelleyEra
-> (TxWits ShelleyEra -> TxWits ShelleyEra) -> TxWits ShelleyEra
forall a b. a -> (a -> b) -> b
& (Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
-> TxWits ShelleyEra -> Identity (TxWits ShelleyEra)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey Witness))
Lens' (TxWits ShelleyEra) (Set (WitVKey Witness))
addrTxWitsL ((Set (WitVKey Witness) -> Identity (Set (WitVKey Witness)))
 -> TxWits ShelleyEra -> Identity (TxWits ShelleyEra))
-> Set (WitVKey Witness) -> TxWits ShelleyEra -> TxWits ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SafeHash EraIndependentTxBody
-> [KeyPair Witness] -> Set (WitVKey Witness)
forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey Witness)
mkWitnessesVKey (TxBody TopTx ShelleyEra -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody TopTx ShelleyEra
txBody) [KeyPair Witness]
keyPairs
        TxWits ShelleyEra
-> (TxWits ShelleyEra -> ShelleyTxWits ShelleyEra)
-> ShelleyTxWits ShelleyEra
forall a b. a -> (a -> b) -> b
& (Map ScriptHash (Script ShelleyEra)
 -> Identity (Map ScriptHash (Script ShelleyEra)))
-> TxWits ShelleyEra -> Identity (TxWits ShelleyEra)
(Map ScriptHash (Script ShelleyEra)
 -> Identity (Map ScriptHash (MultiSig ShelleyEra)))
-> TxWits ShelleyEra -> Identity (ShelleyTxWits ShelleyEra)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits ShelleyEra) (Map ScriptHash (Script ShelleyEra))
scriptTxWitsL ((Map ScriptHash (Script ShelleyEra)
  -> Identity (Map ScriptHash (MultiSig ShelleyEra)))
 -> TxWits ShelleyEra -> Identity (ShelleyTxWits ShelleyEra))
-> Map ScriptHash (MultiSig ShelleyEra)
-> TxWits ShelleyEra
-> ShelleyTxWits ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map ScriptHash (MultiSig ShelleyEra)
msigs

aliceInitCoin :: Coin
aliceInitCoin :: Coin
aliceInitCoin = Integer -> Coin
Coin Integer
10000

bobInitCoin :: Coin
bobInitCoin :: Coin
bobInitCoin = Integer -> Coin
Coin Integer
1000

genesis ::
  forall era.
  ( EraTxOut era
  , EraGov era
  , EraStake era
  , EraCertState era
  ) =>
  LedgerState era
genesis :: forall era.
(EraTxOut era, EraGov era, EraStake era, EraCertState era) =>
LedgerState era
genesis = Map (KeyHash GenesisRole) GenDelegPair
-> UTxO era -> LedgerState era
forall era.
(EraGov era, EraCertState era, EraStake era) =>
Map (KeyHash GenesisRole) GenDelegPair
-> UTxO era -> LedgerState era
genesisState Map (KeyHash GenesisRole) GenDelegPair
forall k a. Map k a
genDelegs0 UTxO era
utxo0
  where
    genDelegs0 :: Map k a
genDelegs0 = Map k a
forall k a. Map k a
Map.empty
    utxo0 :: UTxO era
utxo0 =
      forall era. TxId -> [TxOut era] -> UTxO era
genesisCoins @era
        TxId
genesisId
        [ Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
Cast.aliceAddr (Coin -> Value era
forall t s. Inject t s => t -> s
Val.inject Coin
aliceInitCoin)
        , Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
Cast.bobAddr (Coin -> Value era
forall t s. Inject t s => t -> s
Val.inject Coin
bobInitCoin)
        ]

initPParams :: EraPParams era => PParams era
initPParams :: forall era. EraPParams era => PParams era
initPParams =
  PParams era
forall era. EraPParams era => PParams era
emptyPParams
    PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Word32 -> Identity Word32)
-> PParams era -> Identity (PParams era)
forall era. EraPParams era => Lens' (PParams era) Word32
Lens' (PParams era) Word32
ppMaxTxSizeL ((Word32 -> Identity Word32)
 -> PParams era -> Identity (PParams era))
-> Word32 -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32
1000

-- | Create an initial UTxO state where Alice has 'aliceInitCoin' and Bob
-- 'bobInitCoin' to spend. Then create and apply a transaction which, if
-- 'aliceKeep' is greater than 0, gives that amount to Alice and creates outputs
-- locked by a script for each pair of script, coin value in 'msigs'.
initialUTxOState ::
  Coin ->
  [(MultiSig ShelleyEra, Coin)] ->
  ( TxId
  , Either
      (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
      (UTxOState ShelleyEra)
  )
initialUTxOState :: Coin
-> [(MultiSig ShelleyEra, Coin)]
-> (TxId,
    Either
      (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
      (UTxOState ShelleyEra))
initialUTxOState Coin
aliceKeep [(MultiSig ShelleyEra, Coin)]
msigs =
  let addresses :: [(Addr, Coin)]
addresses =
        [(Addr
Cast.aliceAddr, Coin
aliceKeep) | (Integer -> Integer -> Bool) -> Coin -> Coin -> Bool
forall t. Val t => (Integer -> Integer -> Bool) -> t -> t -> Bool
Val.pointwise Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(>) Coin
aliceKeep Coin
forall a. Monoid a => a
mempty]
          [(Addr, Coin)] -> [(Addr, Coin)] -> [(Addr, Coin)]
forall a. [a] -> [a] -> [a]
++ ((MultiSig ShelleyEra, Coin) -> (Addr, Coin))
-> [(MultiSig ShelleyEra, Coin)] -> [(Addr, Coin)]
forall a b. (a -> b) -> [a] -> [b]
map
            ( \(MultiSig ShelleyEra
msig, Coin
era) ->
                ( Network -> Credential Payment -> StakeReference -> Addr
Addr
                    Network
Testnet
                    (ScriptHash -> Credential Payment
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (ScriptHash -> Credential Payment)
-> ScriptHash -> Credential Payment
forall a b. (a -> b) -> a -> b
$ forall era. EraScript era => Script era -> ScriptHash
hashScript @ShelleyEra Script ShelleyEra
MultiSig ShelleyEra
msig)
                    (Credential Staking -> StakeReference
StakeRefBase (Credential Staking -> StakeReference)
-> Credential Staking -> StakeReference
forall a b. (a -> b) -> a -> b
$ ScriptHash -> Credential Staking
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (ScriptHash -> Credential Staking)
-> ScriptHash -> Credential Staking
forall a b. (a -> b) -> a -> b
$ forall era. EraScript era => Script era -> ScriptHash
hashScript @ShelleyEra Script ShelleyEra
MultiSig ShelleyEra
msig)
                , Coin
era
                )
            )
            [(MultiSig ShelleyEra, Coin)]
msigs
   in let tx :: Tx TopTx ShelleyEra
tx =
            TxBody TopTx ShelleyEra
-> [KeyPair Witness]
-> Map ScriptHash (MultiSig ShelleyEra)
-> Maybe (ShelleyTxAuxData ShelleyEra)
-> Tx TopTx ShelleyEra
makeTx
              ([(Addr, Value ShelleyEra)] -> TxBody TopTx ShelleyEra
initTxBody [(Addr, Value ShelleyEra)]
[(Addr, Coin)]
addresses)
              (KeyPair Payment -> KeyPair Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a Witness
asWitness (KeyPair Payment -> KeyPair Witness)
-> [KeyPair Payment] -> [KeyPair Witness]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [KeyPair Payment
Cast.alicePay, KeyPair Payment
Cast.bobPay])
              Map ScriptHash (MultiSig ShelleyEra)
forall k a. Map k a
Map.empty
              Maybe (ShelleyTxAuxData ShelleyEra)
forall a. Maybe a
Nothing
       in ( Tx TopTx ShelleyEra -> TxId
forall era (l :: TxLevel). EraTx era => Tx l era -> TxId
txIdTx Tx TopTx ShelleyEra
tx
          , ShelleyBase
  (Either
     (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
     (UTxOState ShelleyEra))
-> Either
     (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
     (UTxOState ShelleyEra)
forall a. ShelleyBase a -> a
runShelleyBase (ShelleyBase
   (Either
      (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
      (UTxOState ShelleyEra))
 -> Either
      (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
      (UTxOState ShelleyEra))
-> ShelleyBase
     (Either
        (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
        (UTxOState ShelleyEra))
-> Either
     (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
     (UTxOState ShelleyEra)
forall a b. (a -> b) -> a -> b
$
              forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTSTest @(ShelleyUTXOW ShelleyEra)
                ( (Environment (ShelleyUTXOW ShelleyEra),
 State (ShelleyUTXOW ShelleyEra), Signal (ShelleyUTXOW ShelleyEra))
-> TRC (ShelleyUTXOW ShelleyEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC
                    ( SlotNo
-> PParams ShelleyEra -> CertState ShelleyEra -> UtxoEnv ShelleyEra
forall era. SlotNo -> PParams era -> CertState era -> UtxoEnv era
UtxoEnv
                        (Word64 -> SlotNo
SlotNo Word64
0)
                        PParams ShelleyEra
forall era. EraPParams era => PParams era
initPParams
                        CertState ShelleyEra
ShelleyCertState ShelleyEra
forall a. Default a => a
def
                    , LedgerState ShelleyEra -> UTxOState ShelleyEra
forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState ShelleyEra
forall era.
(EraTxOut era, EraGov era, EraStake era, EraCertState era) =>
LedgerState era
genesis
                    , Tx TopTx ShelleyEra
Signal (ShelleyUTXOW ShelleyEra)
tx
                    )
                )
          )

-- | Start from genesis, consume Alice's and Bob's coins, create an output
-- spendable by Alice if 'aliceKeep' is greater than 0. For each pair of script
-- and coin value in 'lockScripts' create an output of that value locked by the
-- script. Sign the transaction with keys in 'signers'. Then create an
-- transaction that uses the scripts in 'unlockScripts' (and the output for
-- 'aliceKeep' in the case of it being non-zero) to spend all funds back to
-- Alice. Return resulting UTxO state or collected errors
applyTxWithScript ::
  [(MultiSig ShelleyEra, Coin)] ->
  [MultiSig ShelleyEra] ->
  Withdrawals ->
  Coin ->
  [KeyPair Witness] ->
  Either (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra))) (UTxOState ShelleyEra)
applyTxWithScript :: [(MultiSig ShelleyEra, Coin)]
-> [MultiSig ShelleyEra]
-> Withdrawals
-> Coin
-> [KeyPair Witness]
-> Either
     (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
     (UTxOState ShelleyEra)
applyTxWithScript [(MultiSig ShelleyEra, Coin)]
lockScripts [MultiSig ShelleyEra]
unlockScripts Withdrawals
wdrl Coin
aliceKeep [KeyPair Witness]
signers = Either
  (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
  (UTxOState ShelleyEra)
Either
  (NonEmpty (ShelleyUtxowPredFailure ShelleyEra))
  (UTxOState ShelleyEra)
utxoSt'
  where
    (TxId
txId, Either
  (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
  (UTxOState ShelleyEra)
initUtxo) = Coin
-> [(MultiSig ShelleyEra, Coin)]
-> (TxId,
    Either
      (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
      (UTxOState ShelleyEra))
initialUTxOState Coin
aliceKeep [(MultiSig ShelleyEra, Coin)]
lockScripts
    utxoSt :: UTxOState ShelleyEra
utxoSt = case Either
  (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
  (UTxOState ShelleyEra)
initUtxo of
      Right UTxOState ShelleyEra
utxoSt'' -> UTxOState ShelleyEra
utxoSt''
      Either
  (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
  (UTxOState ShelleyEra)
_ -> [Char] -> UTxOState ShelleyEra
forall a. HasCallStack => [Char] -> a
error ([Char] -> UTxOState ShelleyEra) -> [Char] -> UTxOState ShelleyEra
forall a b. (a -> b) -> a -> b
$ [Char]
"must fail test before: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Either
  (NonEmpty (ShelleyUtxowPredFailure ShelleyEra))
  (UTxOState ShelleyEra)
-> [Char]
forall a. Show a => a -> [Char]
show Either
  (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
  (UTxOState ShelleyEra)
Either
  (NonEmpty (ShelleyUtxowPredFailure ShelleyEra))
  (UTxOState ShelleyEra)
initUtxo
    txbody :: TxBody TopTx ShelleyEra
txbody =
      [TxIn]
-> [(Addr, Value ShelleyEra)]
-> Withdrawals
-> TxBody TopTx ShelleyEra
makeTxBody
        [TxIn]
inputs'
        [(Addr
Cast.aliceAddr, Coin -> Value ShelleyEra
forall t s. Inject t s => t -> s
Val.inject (Coin -> Value ShelleyEra) -> Coin -> Value ShelleyEra
forall a b. (a -> b) -> a -> b
$ Coin
aliceInitCoin Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
bobInitCoin Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Map RewardAccount Coin -> Coin
forall m. Monoid m => Map RewardAccount m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Withdrawals -> Map RewardAccount Coin
unWithdrawals Withdrawals
wdrl))]
        Withdrawals
wdrl
    inputs' :: [TxIn]
inputs' =
      [ TxId -> TxIx -> TxIn
TxIn TxId
txId (HasCallStack => Integer -> TxIx
Integer -> TxIx
mkTxIxPartial (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n))
      | Int
n <-
          [Int
0 .. [(MultiSig ShelleyEra, Coin)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(MultiSig ShelleyEra, Coin)]
lockScripts Int -> Int -> Int
forall a. Num a => a -> a -> a
- if (Integer -> Integer -> Bool) -> Coin -> Coin -> Bool
forall t. Val t => (Integer -> Integer -> Bool) -> t -> t -> Bool
Val.pointwise Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(>) Coin
aliceKeep Coin
forall a. Monoid a => a
mempty then Int
0 else Int
1]
      ]
    -- alice? + scripts
    tx :: Tx TopTx ShelleyEra
tx =
      TxBody TopTx ShelleyEra
-> [KeyPair Witness]
-> Map ScriptHash (MultiSig ShelleyEra)
-> Maybe (ShelleyTxAuxData ShelleyEra)
-> Tx TopTx ShelleyEra
makeTx
        TxBody TopTx ShelleyEra
txbody
        [KeyPair Witness]
signers
        ([(ScriptHash, MultiSig ShelleyEra)]
-> Map ScriptHash (MultiSig ShelleyEra)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ScriptHash, MultiSig ShelleyEra)]
 -> Map ScriptHash (MultiSig ShelleyEra))
-> [(ScriptHash, MultiSig ShelleyEra)]
-> Map ScriptHash (MultiSig ShelleyEra)
forall a b. (a -> b) -> a -> b
$ (MultiSig ShelleyEra -> (ScriptHash, MultiSig ShelleyEra))
-> [MultiSig ShelleyEra] -> [(ScriptHash, MultiSig ShelleyEra)]
forall a b. (a -> b) -> [a] -> [b]
map (\MultiSig ShelleyEra
scr -> (forall era. EraScript era => Script era -> ScriptHash
hashScript @ShelleyEra Script ShelleyEra
MultiSig ShelleyEra
scr, MultiSig ShelleyEra
scr)) [MultiSig ShelleyEra]
unlockScripts)
        Maybe (ShelleyTxAuxData ShelleyEra)
forall a. Maybe a
Nothing
    utxoSt' :: Either
  (NonEmpty (ShelleyUtxowPredFailure ShelleyEra))
  (UTxOState ShelleyEra)
utxoSt' =
      ShelleyBase
  (Either
     (NonEmpty (ShelleyUtxowPredFailure ShelleyEra))
     (UTxOState ShelleyEra))
-> Either
     (NonEmpty (ShelleyUtxowPredFailure ShelleyEra))
     (UTxOState ShelleyEra)
forall a. ShelleyBase a -> a
runShelleyBase (ShelleyBase
   (Either
      (NonEmpty (ShelleyUtxowPredFailure ShelleyEra))
      (UTxOState ShelleyEra))
 -> Either
      (NonEmpty (ShelleyUtxowPredFailure ShelleyEra))
      (UTxOState ShelleyEra))
-> ShelleyBase
     (Either
        (NonEmpty (ShelleyUtxowPredFailure ShelleyEra))
        (UTxOState ShelleyEra))
-> Either
     (NonEmpty (ShelleyUtxowPredFailure ShelleyEra))
     (UTxOState ShelleyEra)
forall a b. (a -> b) -> a -> b
$
        forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTSTest @(ShelleyUTXOW ShelleyEra)
          ( (Environment (ShelleyUTXOW ShelleyEra),
 State (ShelleyUTXOW ShelleyEra), Signal (ShelleyUTXOW ShelleyEra))
-> TRC (ShelleyUTXOW ShelleyEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC
              ( SlotNo
-> PParams ShelleyEra -> CertState ShelleyEra -> UtxoEnv ShelleyEra
forall era. SlotNo -> PParams era -> CertState era -> UtxoEnv era
UtxoEnv
                  (Word64 -> SlotNo
SlotNo Word64
0)
                  PParams ShelleyEra
forall era. EraPParams era => PParams era
initPParams
                  CertState ShelleyEra
ShelleyCertState ShelleyEra
forall a. Default a => a
def
              , State (ShelleyUTXOW ShelleyEra)
UTxOState ShelleyEra
utxoSt
              , Tx TopTx ShelleyEra
Signal (ShelleyUTXOW ShelleyEra)
tx
              )
          )