Restructure

`agora-spec` and `agora-spec` is merged to be `agora-specs`;
`agora-testlib` contains what previously was `Spec.Specification`.

agora-specs/Sample/Effect/GovernorMutation.hs

@@ -0,0 +1,193 @@
+module Sample.Effect.GovernorMutation (
+  mkEffectTxInfo,
+  effectValidator,
+  effectValidatorAddress,
+  effectValidatorHash,
+  atAssetClass,
+  govRef,
+  effectRef,
+  invalidNewGovernorDatum,
+  validNewGovernorDatum,
+  mkEffectDatum,
+) where
+
+--------------------------------------------------------------------------------
+
+import Agora.Effect.GovernorMutation (
+  MutateGovernorDatum (..),
+  mutateGovernorValidator,
+ )
+import Agora.Governor (GovernorDatum (..))
+import Agora.Proposal (ProposalId (..), ProposalThresholds (..))
+
+--------------------------------------------------------------------------------
+
+import Data.Tagged (Tagged (..))
+import Plutarch.Api.V1 (mkValidator, validatorHash)
+import Plutus.V1.Ledger.Address (scriptHashAddress)
+import Plutus.V1.Ledger.Api (
+  Address,
+  Datum (..),
+  ToData (..),
+  TokenName (..),
+  TxInInfo (..),
+  TxInfo (..),
+  TxOut (..),
+  TxOutRef (TxOutRef),
+  Validator,
+  ValidatorHash (..),
+ )
+import Plutus.V1.Ledger.Api qualified as Interval
+import Plutus.V1.Ledger.Value (AssetClass, assetClass)
+import Plutus.V1.Ledger.Value qualified as Value
+
+--------------------------------------------------------------------------------
+
+import Sample.Shared (
+  authorityTokenSymbol,
+  govAssetClass,
+  govValidatorAddress,
+  governor,
+  minAda,
+  signer,
+ )
+import Test.Util (datumPair, toDatumHash)
+
+--------------------------------------------------------------------------------
+
+import Data.Default.Class (Default (def))
+
+--------------------------------------------------------------------------------
+
+-- | The effect validator instance.
+effectValidator :: Validator
+effectValidator = mkValidator $ mutateGovernorValidator governor
+
+-- | The hash of the validator instance.
+effectValidatorHash :: ValidatorHash
+effectValidatorHash = validatorHash effectValidator
+
+-- | The address of the validator.
+effectValidatorAddress :: Address
+effectValidatorAddress = scriptHashAddress effectValidatorHash
+
+-- | The assetclass of the authority token.
+atAssetClass :: AssetClass
+atAssetClass = assetClass authorityTokenSymbol tokenName
+  where
+    -- TODO: use 'validatorHashToTokenName'
+    ValidatorHash bs = effectValidatorHash
+    tokenName = TokenName bs
+
+-- | The mock reference of the governor state UTXO.
+govRef :: TxOutRef
+govRef = TxOutRef "614481d2159bfb72350222d61fce17e548e0fc00e5a1f841ff1837c431346ce7" 1
+
+-- | The mock reference of the effect UTXO.
+effectRef :: TxOutRef
+effectRef = TxOutRef "c31164dc11835de7eb6187f67d0e1a19c1dfc0786a456923eef5043189cdb578" 1
+
+-- | The input effect datum in 'mkEffectTransaction'.
+mkEffectDatum :: GovernorDatum -> MutateGovernorDatum
+mkEffectDatum newGovDatum =
+  MutateGovernorDatum
+    { governorRef = govRef
+    , newDatum = newGovDatum
+    }
+
+{- | Given the new governor state, create an effect to update the governor's state.
+
+    Note that the transaction is valid only if the given new datum is valid.
+-}
+mkEffectTxInfo :: GovernorDatum -> TxInfo
+mkEffectTxInfo newGovDatum =
+  let gst = Value.assetClassValue govAssetClass 1
+      at = Value.assetClassValue atAssetClass 1
+
+      -- One authority token is burnt in the process.
+      burnt = Value.assetClassValue atAssetClass (-1)
+
+      --
+
+      governorInputDatum' :: GovernorDatum
+      governorInputDatum' =
+        GovernorDatum
+          { proposalThresholds = def
+          , nextProposalId = ProposalId 0
+          , proposalTimings = def
+          , createProposalTimeRangeMaxWidth = def
+          }
+      governorInputDatum :: Datum
+      governorInputDatum = Datum $ toBuiltinData governorInputDatum'
+      governorInput :: TxOut
+      governorInput =
+        TxOut
+          { txOutAddress = govValidatorAddress
+          , txOutValue = gst
+          , txOutDatumHash = Just $ toDatumHash governorInputDatum
+          }
+
+      --
+
+      -- The effect should update 'nextProposalId'
+      effectInputDatum' :: MutateGovernorDatum
+      effectInputDatum' = mkEffectDatum newGovDatum
+      effectInputDatum :: Datum
+      effectInputDatum = Datum $ toBuiltinData effectInputDatum'
+      effectInput :: TxOut
+      effectInput =
+        TxOut
+          { txOutAddress = effectValidatorAddress
+          , txOutValue = at -- The effect carry an authotity token.
+          , txOutDatumHash = Just $ toDatumHash effectInputDatum
+          }
+
+      --
+
+      governorOutputDatum' :: GovernorDatum
+      governorOutputDatum' = effectInputDatum'.newDatum
+      governorOutputDatum :: Datum
+      governorOutputDatum = Datum $ toBuiltinData governorOutputDatum'
+      governorOutput :: TxOut
+      governorOutput =
+        TxOut
+          { txOutAddress = govValidatorAddress
+          , txOutValue = mconcat [gst, minAda]
+          , txOutDatumHash = Just $ toDatumHash governorOutputDatum
+          }
+   in TxInfo
+        { txInfoInputs =
+            [ TxInInfo effectRef effectInput
+            , TxInInfo govRef governorInput
+            ]
+        , txInfoOutputs = [governorOutput]
+        , txInfoFee = Value.singleton "" "" 2
+        , txInfoMint = burnt
+        , txInfoDCert = []
+        , txInfoWdrl = []
+        , txInfoValidRange = Interval.always
+        , txInfoSignatories = [signer]
+        , txInfoData = datumPair <$> [governorInputDatum, governorOutputDatum, effectInputDatum]
+        , txInfoId = "4dae3806cc69615b721d52ed09b758f43f25a8f39b7934d6b28514caf71f5f7b"
+        }
+
+validNewGovernorDatum :: GovernorDatum
+validNewGovernorDatum =
+  GovernorDatum
+    { proposalThresholds = def
+    , nextProposalId = ProposalId 42
+    , proposalTimings = def
+    , createProposalTimeRangeMaxWidth = def
+    }
+
+invalidNewGovernorDatum :: GovernorDatum
+invalidNewGovernorDatum =
+  GovernorDatum
+    { proposalThresholds =
+        def
+          { countVoting = Tagged (-1)
+          }
+    , nextProposalId = ProposalId 42
+    , proposalTimings = def
+    , createProposalTimeRangeMaxWidth = def
+    }

agora-specs/Sample/Effect/TreasuryWithdrawal.hs

@@ -0,0 +1,172 @@
+{- |
+Module     : Sample.Effect.TreasuryWithdrawalEffect
+Maintainer : seungheon.ooh@gmail.com
+Description: Sample based testing for Treasury Withdrawal Effect
+
+This module provides samples for Treasury Withdrawal Effect tests.
+-}
+module Sample.Effect.TreasuryWithdrawal (
+  inputTreasury,
+  inputUser,
+  inputGAT,
+  inputCollateral,
+  outputTreasury,
+  outputUser,
+  buildReceiversOutputFromDatum,
+  currSymbol,
+  users,
+  treasuries,
+  buildScriptContext,
+) where
+
+import Plutarch.Api.V1 (mkValidator, validatorHash)
+import Plutus.V1.Ledger.Api (
+  Address (Address),
+  Credential (..),
+  CurrencySymbol (CurrencySymbol),
+  DatumHash (DatumHash),
+  PubKeyHash (PubKeyHash),
+  ScriptContext (..),
+  ScriptPurpose (Spending),
+  TokenName (TokenName),
+  TxInInfo (TxInInfo),
+  TxInfo (
+    TxInfo,
+    txInfoDCert,
+    txInfoData,
+    txInfoFee,
+    txInfoId,
+    txInfoInputs,
+    txInfoMint,
+    txInfoOutputs,
+    txInfoSignatories,
+    txInfoValidRange,
+    txInfoWdrl
+  ),
+  TxOut (..),
+  TxOutRef (TxOutRef),
+  Validator,
+  ValidatorHash (ValidatorHash),
+  Value,
+  toBuiltin,
+ )
+import Plutus.V1.Ledger.Interval qualified as Interval
+import Plutus.V1.Ledger.Value qualified as Value
+
+import Data.ByteString.Char8 qualified as C
+import Data.ByteString.Hash (sha2)
+
+import Agora.Effect.TreasuryWithdrawal (
+  TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
+  treasuryWithdrawalValidator,
+ )
+
+-- | A sample Currency Symbol.
+currSymbol :: CurrencySymbol
+currSymbol = CurrencySymbol "12312099"
+
+-- | A sample 'PubKeyHash'.
+signer :: PubKeyHash
+signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
+
+-- | List of users who the effect will pay to.
+users :: [Credential]
+users = PubKeyCredential . PubKeyHash . toBuiltin . sha2 . C.pack . show <$> ([1 ..] :: [Integer])
+
+-- | List of users who the effect will pay to.
+treasuries :: [Credential]
+treasuries = ScriptCredential . ValidatorHash . toBuiltin . sha2 . C.pack . show <$> ([1 ..] :: [Integer])
+
+inputGAT :: TxInInfo
+inputGAT =
+  TxInInfo
+    (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+    TxOut
+      { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
+      , txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST
+      , txOutDatumHash = Just (DatumHash "")
+      }
+
+inputTreasury :: Int -> Value -> TxInInfo
+inputTreasury indx val =
+  TxInInfo
+    (TxOutRef "" 1)
+    TxOut
+      { txOutAddress = Address (treasuries !! indx) Nothing
+      , txOutValue = val
+      , txOutDatumHash = Just (DatumHash "")
+      }
+
+inputUser :: Int -> Value -> TxInInfo
+inputUser indx val =
+  TxInInfo
+    (TxOutRef "" 1)
+    TxOut
+      { txOutAddress = Address (users !! indx) Nothing
+      , txOutValue = val
+      , txOutDatumHash = Just (DatumHash "")
+      }
+
+inputCollateral :: Int -> TxInInfo
+inputCollateral indx =
+  TxInInfo -- Initiator
+    (TxOutRef "" 1)
+    TxOut
+      { txOutAddress = Address (users !! indx) Nothing
+      , txOutValue = Value.singleton "" "" 2000000
+      , txOutDatumHash = Just (DatumHash "")
+      }
+
+outputTreasury :: Int -> Value -> TxOut
+outputTreasury indx val =
+  TxOut
+    { txOutAddress = Address (treasuries !! indx) Nothing
+    , txOutValue = val
+    , txOutDatumHash = Nothing
+    }
+
+outputUser :: Int -> Value -> TxOut
+outputUser indx val =
+  TxOut
+    { txOutAddress = Address (users !! indx) Nothing
+    , txOutValue = val
+    , txOutDatumHash = Nothing
+    }
+
+buildReceiversOutputFromDatum :: TreasuryWithdrawalDatum -> [TxOut]
+buildReceiversOutputFromDatum (TreasuryWithdrawalDatum xs _) = f <$> xs
+  where
+    f x =
+      TxOut
+        { txOutAddress = Address (fst x) Nothing
+        , txOutValue = snd x
+        , txOutDatumHash = Nothing
+        }
+
+-- | Effect validator instance.
+validator :: Validator
+validator = mkValidator $ treasuryWithdrawalValidator currSymbol
+
+-- | 'TokenName' that represents the hash of the 'Stake' validator.
+validatorHashTN :: TokenName
+validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh
+
+buildScriptContext :: [TxInInfo] -> [TxOut] -> ScriptContext
+buildScriptContext inputs outputs =
+  ScriptContext
+    { scriptContextTxInfo =
+        TxInfo
+          { txInfoInputs = inputs
+          , txInfoOutputs = outputs
+          , txInfoFee = Value.singleton "" "" 2
+          , txInfoMint = Value.singleton currSymbol validatorHashTN (-1)
+          , txInfoDCert = []
+          , txInfoWdrl = []
+          , txInfoValidRange = Interval.always
+          , txInfoSignatories = [signer]
+          , txInfoData = []
+          , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
+          }
+    , scriptContextPurpose =
+        Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+    }

agora-specs/Sample/Governor.hs

@@ -0,0 +1,650 @@
+{- |
+Module     : Spec.Sample.Governor
+Maintainer : connor@mlabs.city
+Description: Sample based testing for Governor utxos
+
+This module tests primarily the happy path for Governor interactions
+-}
+module Sample.Governor (
+  createProposal,
+  mutateState,
+  mintGATs,
+  mintGST,
+) where
+
+--------------------------------------------------------------------------------
+
+import Data.Tagged (Tagged (..), untag)
+import Plutarch.Api.V1 (mkValidator, validatorHash)
+
+--------------------------------------------------------------------------------
+
+import Plutus.V1.Ledger.Address (scriptHashAddress)
+import Plutus.V1.Ledger.Api (
+  Address (..),
+  Credential (ScriptCredential),
+  Datum (..),
+  ScriptContext (..),
+  ScriptPurpose (Minting, Spending),
+  ToData (toBuiltinData),
+  TokenName (..),
+  TxInInfo (TxInInfo),
+  TxInfo (..),
+  TxOut (..),
+  TxOutRef (..),
+  Validator,
+  ValidatorHash (..),
+ )
+import Plutus.V1.Ledger.Interval qualified as Interval
+import Plutus.V1.Ledger.Scripts (unitDatum)
+import Plutus.V1.Ledger.Value (
+  AssetClass (..),
+ )
+import Plutus.V1.Ledger.Value qualified as Value
+import PlutusTx.AssocMap qualified as AssocMap
+
+--------------------------------------------------------------------------------
+
+import Agora.Effect.NoOp (noOpValidator)
+import Agora.Governor (GovernorDatum (..), getNextProposalId)
+import Agora.Proposal (
+  ProposalDatum (..),
+  ProposalId (..),
+  ProposalStatus (..),
+  ProposalVotes (..),
+  ResultTag (..),
+  emptyVotesFor,
+ )
+import Agora.Proposal qualified as P
+import Agora.Proposal.Time (
+  ProposalStartingTime (ProposalStartingTime),
+  ProposalTimingConfig (..),
+ )
+import Agora.Stake (
+  ProposalLock (..),
+  Stake (..),
+  StakeDatum (..),
+ )
+
+--------------------------------------------------------------------------------
+
+import Sample.Shared (
+  authorityTokenSymbol,
+  govAssetClass,
+  govSymbol,
+  govValidatorAddress,
+  gstUTXORef,
+  minAda,
+  proposalPolicySymbol,
+  proposalStartingTimeFromTimeRange,
+  proposalValidatorAddress,
+  signer,
+  signer2,
+  stake,
+  stakeAddress,
+  stakeAssetClass,
+ )
+import Test.Util (closedBoundedInterval, datumPair, toDatumHash)
+
+--------------------------------------------------------------------------------
+
+import Data.Default.Class (Default (def))
+
+--------------------------------------------------------------------------------
+
+{- | A valid 'ScriptContext' for minting GST.
+
+    - Only the minting policy will be ran in the transaction.
+    - An arbitrary UTXO is spent to create the token.
+
+        - We call this the "witness" UTXO.
+        - This UTXO is referenced in the 'Agora.Governor.Governor' parameter
+        - The minting policy should only be ran once its life time,
+          cause the GST cannot be minted twice or burnt.
+
+    - The output UTXO must carry a valid 'GovernorDatum'.
+    - It's worth noticing that the transaction should send the GST to the governor validator,
+        but unfortunately we can't check it in the policy. The GST will stay at the address of
+        the governor validator forever once the token is under control of the said validator.
+
+    TODO: tag the output UTXO with the target address.
+-}
+mintGST :: ScriptContext
+mintGST =
+  let gst = Value.assetClassValue govAssetClass 1
+
+      ---
+
+      governorOutputDatum' :: GovernorDatum
+      governorOutputDatum' =
+        GovernorDatum
+          { proposalThresholds = def
+          , nextProposalId = ProposalId 0
+          , proposalTimings = def
+          , createProposalTimeRangeMaxWidth = def
+          }
+      governorOutputDatum :: Datum
+      governorOutputDatum = Datum $ toBuiltinData governorOutputDatum'
+      governorOutput :: TxOut
+      governorOutput =
+        TxOut
+          { txOutAddress = govValidatorAddress
+          , txOutValue = gst <> minAda
+          , txOutDatumHash = Just $ toDatumHash governorOutputDatum
+          }
+
+      ---
+
+      witness :: ValidatorHash
+      witness = "a926a9a72a0963f428e3252caa8354e655603996fb8892d6b8323fd072345924"
+      witnessAddress :: Address
+      witnessAddress = Address (ScriptCredential witness) Nothing
+
+      ---
+
+      -- The witness UTXO must be consumed.
+      witnessInput :: TxOut
+      witnessInput =
+        TxOut
+          { txOutAddress = witnessAddress
+          , txOutValue = mempty
+          , txOutDatumHash = Nothing
+          }
+      initialSpend :: TxInInfo
+      initialSpend = TxInInfo gstUTXORef witnessInput
+   in ScriptContext
+        { scriptContextTxInfo =
+            TxInfo
+              { txInfoInputs =
+                  [ initialSpend
+                  ]
+              , txInfoOutputs = [governorOutput]
+              , -- Some ada to cover the transaction fee
+                txInfoFee = Value.singleton "" "" 2
+              , -- Exactly one GST is minted
+                txInfoMint = gst
+              , txInfoDCert = []
+              , txInfoWdrl = []
+              , txInfoValidRange = Interval.always
+              , txInfoSignatories = [signer]
+              , txInfoData = [datumPair governorOutputDatum]
+              , txInfoId = "90906d3e6b4d6dec2e747dcdd9617940ea8358164c7244694cfa39dec18bd9d4"
+              }
+        , scriptContextPurpose = Minting govSymbol
+        }
+
+{- | A valid script context to create a proposal.
+
+    Three component will run in the transaction:
+    TODO: mention redeemers
+
+    - Governor validator
+    - Stake validator
+    - Proposal policy
+
+    The components will ensure:
+
+    - The governor state UTXO is spent
+
+        - A new UTXO is paid back to governor validator, which carries the GST.
+        - The proposal id in the state datum is advanced.
+
+    - A new UTXO is sent to the proposal validator
+
+        - The UTXO contains a newly minted proposal state token.
+        - It also carries a legal proposal state datum, whose status is set to 'Agora.Proposal.Draft'.
+
+    - A stake is spent to create a proposal
+
+        - The stake owner must sign the transaction.
+        - The output stake must paid back to the stake validator.
+        - The output stake is locked by the newly created proposal.
+-}
+createProposal :: ScriptContext
+createProposal =
+  let pst = Value.singleton proposalPolicySymbol "" 1
+      gst = Value.assetClassValue govAssetClass 1
+      sst = Value.assetClassValue stakeAssetClass 1
+      stackedGTs = 424242424242
+      thisProposalId = ProposalId 0
+
+      ---
+
+      governorInputDatum' :: GovernorDatum
+      governorInputDatum' =
+        GovernorDatum
+          { proposalThresholds = def
+          , nextProposalId = thisProposalId
+          , proposalTimings = def
+          , createProposalTimeRangeMaxWidth = def
+          }
+      governorInputDatum :: Datum
+      governorInputDatum = Datum $ toBuiltinData governorInputDatum'
+      governorInput :: TxOut
+      governorInput =
+        TxOut
+          { txOutAddress = govValidatorAddress
+          , txOutValue = gst
+          , txOutDatumHash = Just $ toDatumHash governorInputDatum
+          }
+
+      ---
+
+      effects =
+        AssocMap.fromList
+          [ (ResultTag 0, AssocMap.empty)
+          , (ResultTag 1, AssocMap.empty)
+          ]
+      proposalDatum :: Datum
+      proposalDatum =
+        Datum
+          ( toBuiltinData $
+              ProposalDatum
+                { P.proposalId = ProposalId 0
+                , effects = effects
+                , status = Draft
+                , cosigners = [signer]
+                , thresholds = def
+                , votes = emptyVotesFor effects
+                , timingConfig = def
+                , startingTime = proposalStartingTimeFromTimeRange validTimeRange
+                }
+          )
+      proposalOutput :: TxOut
+      proposalOutput =
+        TxOut
+          { txOutAddress = proposalValidatorAddress
+          , txOutValue = pst <> minAda
+          , txOutDatumHash = Just (toDatumHash proposalDatum)
+          }
+
+      ---
+
+      stakeInputDatum' :: StakeDatum
+      stakeInputDatum' =
+        StakeDatum
+          { stakedAmount = Tagged stackedGTs
+          , owner = signer
+          , lockedBy = []
+          }
+      stakeInputDatum :: Datum
+      stakeInputDatum = Datum $ toBuiltinData stakeInputDatum'
+      stakeInput :: TxOut
+      stakeInput =
+        TxOut
+          { txOutAddress = stakeAddress
+          , txOutValue = sst <> Value.assetClassValue (untag stake.gtClassRef) stackedGTs
+          , txOutDatumHash = Just (toDatumHash stakeInputDatum)
+          }
+
+      ---
+      governorOutputDatum' :: GovernorDatum
+      governorOutputDatum' = governorInputDatum' {nextProposalId = getNextProposalId thisProposalId}
+      governorOutputDatum :: Datum
+      governorOutputDatum = Datum $ toBuiltinData governorOutputDatum'
+      governorOutput :: TxOut
+      governorOutput =
+        governorInput
+          { txOutDatumHash = Just $ toDatumHash governorOutputDatum
+          , txOutValue = gst <> minAda
+          }
+
+      ---
+
+      proposalLocks :: [ProposalLock]
+      proposalLocks =
+        [ ProposalLock (ResultTag 0) thisProposalId
+        , ProposalLock (ResultTag 1) thisProposalId
+        ]
+      stakeOutputDatum' :: StakeDatum
+      stakeOutputDatum' = stakeInputDatum' {lockedBy = proposalLocks}
+      stakeOutputDatum :: Datum
+      stakeOutputDatum = Datum $ toBuiltinData stakeOutputDatum'
+      stakeOutput :: TxOut
+      stakeOutput =
+        stakeInput
+          { txOutDatumHash = Just $ toDatumHash stakeOutputDatum
+          , txOutValue = sst <> Value.assetClassValue (untag stake.gtClassRef) stackedGTs <> minAda
+          }
+
+      ---
+
+      ownInputRef :: TxOutRef
+      ownInputRef = TxOutRef "4355a46b19d348dc2f57c046f8ef63d4538ebb936000f3c9ee954a27460dd865" 1
+
+      ---
+
+      validTimeRange = closedBoundedInterval 10 15
+   in ScriptContext
+        { scriptContextTxInfo =
+            TxInfo
+              { txInfoInputs =
+                  [ TxInInfo
+                      ownInputRef
+                      governorInput
+                  , TxInInfo
+                      (TxOutRef "4262bbd0b3fc926b74eaa8abab5def6ce5e6b94f19cf221c02a16e7da8cd470f" 1)
+                      stakeInput
+                  ]
+              , txInfoOutputs = [proposalOutput, governorOutput, stakeOutput]
+              , txInfoFee = Value.singleton "" "" 2
+              , txInfoMint = pst
+              , txInfoDCert = []
+              , txInfoWdrl = []
+              , txInfoValidRange = validTimeRange
+              , txInfoSignatories = [signer]
+              , txInfoData =
+                  datumPair
+                    <$> [ governorInputDatum
+                        , governorOutputDatum
+                        , proposalDatum
+                        , stakeInputDatum
+                        , stakeOutputDatum
+                        ]
+              , txInfoId = "1ffb9669335c908d9a4774a4bf7aa7bfafec91d015249b4138bc83fde4a3330a"
+              }
+        , scriptContextPurpose = Spending ownInputRef
+        }
+
+{- This script context should be a valid transaction for minting authority for the effect scrips.
+
+    The following components will run:
+
+    - Governor validator
+    - Authority policy
+    - Proposal validator
+
+    There should be only one proposal the transaction.
+    The validity of the proposal will be checked:
+
+    - It's in 'Agora.Proposal.Locked' state.
+    - It has a 'winner' effect group, meaning that the votes meet the requirements.
+
+    The system will ensure that for every effect scrips in said effect group,
+    a newly minted GAT is sent to the corresponding effect, and properly tagged.
+-}
+mintGATs :: ScriptContext
+mintGATs =
+  let pst = Value.singleton proposalPolicySymbol "" 1
+      gst = Value.assetClassValue govAssetClass 1
+      gat = Value.assetClassValue atAssetClass 1
+
+      ---
+
+      mockEffect :: Validator
+      mockEffect = mkValidator $ noOpValidator ""
+      mockEffectHash :: ValidatorHash
+      mockEffectHash = validatorHash mockEffect
+      mockEffectAddress :: Address
+      mockEffectAddress = scriptHashAddress mockEffectHash
+      mockEffectOutputDatum :: Datum
+      mockEffectOutputDatum = unitDatum
+      atTokenName :: TokenName
+      atTokenName = TokenName hash
+        where
+          ValidatorHash hash = mockEffectHash
+      atAssetClass :: AssetClass
+      atAssetClass = AssetClass (authorityTokenSymbol, atTokenName)
+
+      ---
+
+      governorInputDatum' :: GovernorDatum
+      governorInputDatum' =
+        GovernorDatum
+          { proposalThresholds = def
+          , nextProposalId = ProposalId 5
+          , proposalTimings = def
+          , createProposalTimeRangeMaxWidth = def
+          }
+      governorInputDatum :: Datum
+      governorInputDatum = Datum $ toBuiltinData governorInputDatum'
+      governorInput :: TxOut
+      governorInput =
+        TxOut
+          { txOutAddress = govValidatorAddress
+          , txOutValue = gst
+          , txOutDatumHash = Just $ toDatumHash governorInputDatum
+          }
+
+      ---
+
+      effects =
+        AssocMap.fromList
+          [ (ResultTag 0, AssocMap.empty)
+          , (ResultTag 1, AssocMap.singleton mockEffectHash $ toDatumHash mockEffectOutputDatum)
+          ]
+      proposalVotes :: ProposalVotes
+      proposalVotes =
+        ProposalVotes $
+          AssocMap.fromList
+            [ (ResultTag 0, 100)
+            , (ResultTag 1, 2000) -- The winner
+            ]
+      proposalInputDatum' :: ProposalDatum
+      proposalInputDatum' =
+        ProposalDatum
+          { P.proposalId = ProposalId 0
+          , effects = effects
+          , status = Locked
+          , cosigners = [signer, signer2]
+          , thresholds = def
+          , votes = proposalVotes
+          , timingConfig = def
+          , startingTime = ProposalStartingTime 10
+          }
+      proposalInputDatum :: Datum
+      proposalInputDatum = Datum $ toBuiltinData proposalInputDatum'
+      proposalInput :: TxOut
+      proposalInput =
+        TxOut
+          { txOutAddress = proposalValidatorAddress
+          , txOutValue = pst
+          , txOutDatumHash = Just (toDatumHash proposalInputDatum)
+          }
+
+      ---
+
+      governorOutputDatum' :: GovernorDatum
+      governorOutputDatum' = governorInputDatum'
+      governorOutputDatum :: Datum
+      governorOutputDatum = Datum $ toBuiltinData governorOutputDatum'
+      governorOutput :: TxOut
+      governorOutput =
+        governorInput
+          { txOutDatumHash = Just $ toDatumHash governorOutputDatum
+          , txOutValue = gst <> minAda
+          }
+
+      ---
+
+      proposalOutputDatum' :: ProposalDatum
+      proposalOutputDatum' = proposalInputDatum' {status = Finished}
+      proposalOutputDatum :: Datum
+      proposalOutputDatum = Datum $ toBuiltinData proposalOutputDatum'
+      proposalOutput :: TxOut
+      proposalOutput =
+        proposalInput
+          { txOutDatumHash = Just $ toDatumHash proposalOutputDatum
+          , txOutValue = pst <> minAda
+          }
+
+      --
+
+      mockEffectOutput :: TxOut
+      mockEffectOutput =
+        TxOut
+          { txOutAddress = mockEffectAddress
+          , txOutDatumHash = Just $ toDatumHash mockEffectOutputDatum
+          , txOutValue = gat <> minAda
+          }
+
+      --
+
+      ownInputRef :: TxOutRef
+      ownInputRef = TxOutRef "4355a46b19d348dc2f57c046f8ef63d4538ebb936000f3c9ee954a27460dd865" 1
+
+      --
+      validTimeRange =
+        closedBoundedInterval
+          ((def :: ProposalTimingConfig).lockingTime + 11)
+          ((def :: ProposalTimingConfig).executingTime - 11)
+   in ScriptContext
+        { scriptContextTxInfo =
+            TxInfo
+              { txInfoInputs =
+                  [ TxInInfo ownInputRef governorInput
+                  , TxInInfo
+                      (TxOutRef "11b2162f267614b803761032b6333040fc61478ae788c088614ee9487ab0c1b7" 1)
+                      proposalInput
+                  ]
+              , txInfoOutputs =
+                  [ governorOutput
+                  , proposalOutput
+                  , mockEffectOutput
+                  ]
+              , txInfoFee = Value.singleton "" "" 2
+              , txInfoMint = gat
+              , txInfoDCert = []
+              , txInfoWdrl = []
+              , txInfoValidRange = validTimeRange
+              , txInfoSignatories = [signer, signer2]
+              , txInfoData =
+                  datumPair
+                    <$> [ governorInputDatum
+                        , governorOutputDatum
+                        , proposalInputDatum
+                        , proposalOutputDatum
+                        , mockEffectOutputDatum
+                        ]
+              , txInfoId = "ff755f613c1f7487dfbf231325c67f481f7a97e9faf4d8b09ad41176fd65cbe7"
+              }
+        , scriptContextPurpose = Spending ownInputRef
+        }
+
+{- | A valid script context for changing the state datum of the governor.
+
+    In this case, the following components will run:
+
+    * Governor validator
+    * Effect script
+
+    The effect script should carry an valid tagged authority token,
+      and said token will be burnt in the transaction. We use 'noOpValidator'
+      here as a mock effect, so no actual change is done to the governor state.
+    TODO: use 'Agora.Effect.GovernorMutation.mutateGovernorEffect' as the mock effect in the future.
+
+    The governor will ensure the new governor state is valid.
+-}
+mutateState :: ScriptContext
+mutateState =
+  let gst = Value.assetClassValue govAssetClass 1
+      gat = Value.assetClassValue atAssetClass 1
+      burntGAT = Value.assetClassValue atAssetClass (-1)
+
+      ---
+
+      -- TODO: Use the *real* effect, see https://github.com/Liqwid-Labs/agora/pull/62
+
+      mockEffect :: Validator
+      mockEffect = mkValidator $ noOpValidator ""
+      mockEffectHash :: ValidatorHash
+      mockEffectHash = validatorHash mockEffect
+      mockEffectAddress :: Address
+      mockEffectAddress = scriptHashAddress mockEffectHash
+      atTokenName :: TokenName
+      atTokenName = TokenName hash
+        where
+          ValidatorHash hash = mockEffectHash
+      atAssetClass :: AssetClass
+      atAssetClass = AssetClass (authorityTokenSymbol, atTokenName)
+
+      --
+
+      mockEffectInputDatum :: Datum
+      mockEffectInputDatum = unitDatum
+      mockEffectInput :: TxOut
+      mockEffectInput =
+        TxOut
+          { txOutAddress = mockEffectAddress
+          , txOutValue = gat -- Will be burnt
+          , txOutDatumHash = Just $ toDatumHash mockEffectInputDatum
+          }
+
+      --
+
+      mockEffectOutputDatum :: Datum
+      mockEffectOutputDatum = mockEffectInputDatum
+      mockEffectOutput :: TxOut
+      mockEffectOutput =
+        mockEffectInput
+          { txOutValue = minAda
+          , txOutDatumHash = Just $ toDatumHash mockEffectOutputDatum
+          }
+
+      --
+
+      governorInputDatum' :: GovernorDatum
+      governorInputDatum' =
+        GovernorDatum
+          { proposalThresholds = def
+          , nextProposalId = ProposalId 5
+          , proposalTimings = def
+          , createProposalTimeRangeMaxWidth = def
+          }
+      governorInputDatum :: Datum
+      governorInputDatum = Datum $ toBuiltinData governorInputDatum'
+      governorInput :: TxOut
+      governorInput =
+        TxOut
+          { txOutAddress = govValidatorAddress
+          , txOutValue = gst
+          , txOutDatumHash = Just $ toDatumHash governorInputDatum
+          }
+
+      --
+
+      governorOutputDatum' :: GovernorDatum
+      governorOutputDatum' = governorInputDatum'
+      governorOutputDatum :: Datum
+      governorOutputDatum = Datum $ toBuiltinData governorOutputDatum'
+      governorOutput :: TxOut
+      governorOutput =
+        governorInput
+          { txOutDatumHash = Just $ toDatumHash governorOutputDatum
+          , txOutValue = gst <> minAda
+          }
+
+      --
+
+      ownInputRef :: TxOutRef
+      ownInputRef = TxOutRef "f867238a04597c99a0b9858746557d305025cca3b9f78ea14d5c88c4cfcf58ff" 1
+   in ScriptContext
+        { scriptContextTxInfo =
+            TxInfo
+              { txInfoInputs =
+                  [ TxInInfo ownInputRef governorInput
+                  , TxInInfo
+                      (TxOutRef "ecff06d7cf99089294569cc8b92609e44927278f9901730715d14634fbc10089" 1)
+                      mockEffectInput
+                  ]
+              , txInfoOutputs =
+                  [ governorOutput
+                  , mockEffectOutput
+                  ]
+              , txInfoFee = Value.singleton "" "" 2
+              , txInfoMint = burntGAT
+              , txInfoDCert = []
+              , txInfoWdrl = []
+              , txInfoValidRange = Interval.always
+              , txInfoSignatories = [signer]
+              , txInfoData =
+                  datumPair
+                    <$> [ governorInputDatum
+                        , governorOutputDatum
+                        , mockEffectInputDatum
+                        , mockEffectOutputDatum
+                        ]
+              , txInfoId = "9a12a605086a9f866731869a42d0558036fc739c74fea3849aa41562c015aaf9"
+              }
+        , scriptContextPurpose = Spending ownInputRef
+        }

agora-specs/Sample/Proposal.hs

@@ -0,0 +1,822 @@
+{- |
+Module     : Sample.Proposal
+Maintainer : emi@haskell.fyi
+Description: Sample based testing for Proposal utxos
+
+This module tests primarily the happy path for Proposal interactions
+-}
+module Sample.Proposal (
+  -- * Script contexts
+  proposalCreation,
+  cosignProposal,
+  proposalRef,
+  stakeRef,
+  voteOnProposal,
+  VotingParameters (..),
+  advanceProposalSuccess,
+  advanceProposalFailureTimeout,
+  TransitionParameters (..),
+  advanceFinishedPropsoal,
+  advanceProposalInsufficientVotes,
+  advancePropsoalWithsStake,
+) where
+
+--------------------------------------------------------------------------------
+
+import Plutarch.Api.V1 (
+  validatorHash,
+ )
+
+--------------------------------------------------------------------------------
+
+import Plutus.V1.Ledger.Api (
+  Address (Address),
+  Credential (ScriptCredential),
+  Datum (Datum),
+  DatumHash,
+  POSIXTime,
+  POSIXTimeRange,
+  PubKeyHash,
+  ScriptContext (..),
+  ScriptPurpose (..),
+  ToData (toBuiltinData),
+  TxInInfo (TxInInfo),
+  TxInfo (..),
+  TxOut (TxOut, txOutAddress, txOutDatumHash, txOutValue),
+  TxOutRef (TxOutRef),
+  ValidatorHash,
+ )
+import Plutus.V1.Ledger.Value qualified as Value
+import PlutusTx.AssocMap qualified as AssocMap
+
+--------------------------------------------------------------------------------
+
+import Agora.Governor (
+  GovernorDatum (..),
+ )
+import Agora.Proposal (
+  Proposal (..),
+  ProposalDatum (..),
+  ProposalId (..),
+  ProposalStatus (..),
+  ProposalThresholds (..),
+  ProposalVotes (..),
+  ResultTag (..),
+  emptyVotesFor,
+ )
+import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime), ProposalTimingConfig (..))
+import Agora.Stake (ProposalLock (ProposalLock), Stake (..), StakeDatum (..))
+import Data.Tagged (Tagged (..), untag)
+import Sample.Shared
+import Test.Util (closedBoundedInterval, datumPair, toDatumHash, updateMap)
+
+--------------------------------------------------------------------------------
+
+import Data.Default.Class (Default (def))
+
+--------------------------------------------------------------------------------
+
+-- | This script context should be a valid transaction.
+proposalCreation :: ScriptContext
+proposalCreation =
+  let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST
+      effects =
+        AssocMap.fromList
+          [ (ResultTag 0, AssocMap.empty)
+          , (ResultTag 1, AssocMap.empty)
+          ]
+      proposalDatum :: Datum
+      proposalDatum =
+        Datum
+          ( toBuiltinData $
+              ProposalDatum
+                { proposalId = ProposalId 0
+                , effects = effects
+                , status = Draft
+                , cosigners = [signer]
+                , thresholds = def
+                , votes = emptyVotesFor effects
+                , timingConfig = def
+                , startingTime = proposalStartingTimeFromTimeRange validTimeRange
+                }
+          )
+
+      govBefore :: Datum
+      govBefore =
+        Datum
+          ( toBuiltinData $
+              GovernorDatum
+                { proposalThresholds = def
+                , nextProposalId = ProposalId 0
+                , proposalTimings = def
+                , createProposalTimeRangeMaxWidth = def
+                }
+          )
+      govAfter :: Datum
+      govAfter =
+        Datum
+          ( toBuiltinData $
+              GovernorDatum
+                { proposalThresholds = def
+                , nextProposalId = ProposalId 1
+                , proposalTimings = def
+                , createProposalTimeRangeMaxWidth = def
+                }
+          )
+
+      validTimeRange = closedBoundedInterval 10 15
+   in ScriptContext
+        { scriptContextTxInfo =
+            TxInfo
+              { txInfoInputs =
+                  [ TxInInfo
+                      (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+                      TxOut
+                        { txOutAddress = Address (ScriptCredential $ validatorHash govValidator) Nothing
+                        , txOutValue = Value.assetClassValue proposal.governorSTAssetClass 1
+                        , txOutDatumHash = Just (toDatumHash govBefore)
+                        }
+                  ]
+              , txInfoOutputs =
+                  [ TxOut
+                      { txOutAddress = Address (ScriptCredential proposalValidatorHash) Nothing
+                      , txOutValue =
+                          mconcat
+                            [ st
+                            , Value.singleton "" "" 10_000_000
+                            ]
+                      , txOutDatumHash = Just (toDatumHash proposalDatum)
+                      }
+                  , TxOut
+                      { txOutAddress = Address (ScriptCredential $ validatorHash govValidator) Nothing
+                      , txOutValue =
+                          mconcat
+                            [ Value.assetClassValue proposal.governorSTAssetClass 1
+                            , Value.singleton "" "" 10_000_000
+                            ]
+                      , txOutDatumHash = Just (toDatumHash govAfter)
+                      }
+                  ]
+              , txInfoFee = Value.singleton "" "" 2
+              , txInfoMint = st
+              , txInfoDCert = []
+              , txInfoWdrl = []
+              , txInfoValidRange = validTimeRange
+              , txInfoSignatories = [signer]
+              , txInfoData =
+                  [ datumPair proposalDatum
+                  , datumPair govBefore
+                  , datumPair govAfter
+                  ]
+              , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
+              }
+        , scriptContextPurpose = Minting proposalPolicySymbol
+        }
+
+proposalRef :: TxOutRef
+proposalRef = TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1
+
+stakeRef :: TxOutRef
+stakeRef = TxOutRef "0ca36f3a357bc69579ab2531aecd1e7d3714d993c7820f40b864be15" 0
+
+-- | This script context should be a valid transaction.
+cosignProposal :: [PubKeyHash] -> TxInfo
+cosignProposal newSigners =
+  let st = Value.singleton proposalPolicySymbol "" 1 -- Proposal ST
+      effects =
+        AssocMap.fromList
+          [ (ResultTag 0, AssocMap.empty)
+          , (ResultTag 1, AssocMap.empty)
+          ]
+      proposalBefore :: ProposalDatum
+      proposalBefore =
+        ProposalDatum
+          { proposalId = ProposalId 0
+          , effects = effects
+          , status = Draft
+          , cosigners = [signer]
+          , thresholds = def
+          , votes = emptyVotesFor effects
+          , timingConfig = def
+          , startingTime = ProposalStartingTime 0
+          }
+      stakeDatum :: StakeDatum
+      stakeDatum = StakeDatum (Tagged 50_000_000) signer2 []
+      proposalAfter :: ProposalDatum
+      proposalAfter = proposalBefore {cosigners = newSigners <> proposalBefore.cosigners}
+      validTimeRange :: POSIXTimeRange
+      validTimeRange =
+        closedBoundedInterval
+          10
+          ((def :: ProposalTimingConfig).draftTime - 10)
+   in TxInfo
+        { txInfoInputs =
+            [ TxInInfo
+                proposalRef
+                TxOut
+                  { txOutAddress = proposalValidatorAddress
+                  , txOutValue =
+                      mconcat
+                        [ st
+                        , Value.singleton "" "" 10_000_000
+                        ]
+                  , txOutDatumHash = Just (toDatumHash proposalBefore)
+                  }
+            , TxInInfo
+                stakeRef
+                TxOut
+                  { txOutAddress = stakeAddress
+                  , txOutValue =
+                      mconcat
+                        [ Value.singleton "" "" 10_000_000
+                        , Value.assetClassValue (untag stake.gtClassRef) 50_000_000
+                        , Value.assetClassValue stakeAssetClass 1
+                        ]
+                  , txOutDatumHash = Just (toDatumHash stakeDatum)
+                  }
+            ]
+        , txInfoOutputs =
+            [ TxOut
+                { txOutAddress = Address (ScriptCredential proposalValidatorHash) Nothing
+                , txOutValue =
+                    mconcat
+                      [ st
+                      , Value.singleton "" "" 10_000_000
+                      ]
+                , txOutDatumHash = Just (toDatumHash . Datum $ toBuiltinData proposalAfter)
+                }
+            , TxOut
+                { txOutAddress = stakeAddress
+                , txOutValue =
+                    mconcat
+                      [ Value.singleton "" "" 10_000_000
+                      , Value.assetClassValue (untag stake.gtClassRef) 50_000_000
+                      , Value.assetClassValue stakeAssetClass 1
+                      ]
+                , txOutDatumHash = Just (toDatumHash stakeDatum)
+                }
+            ]
+        , txInfoFee = Value.singleton "" "" 2
+        , txInfoMint = st
+        , txInfoDCert = []
+        , txInfoWdrl = []
+        , txInfoValidRange = validTimeRange
+        , txInfoSignatories = newSigners
+        , txInfoData =
+            [ datumPair . Datum $ toBuiltinData proposalBefore
+            , datumPair . Datum $ toBuiltinData proposalAfter
+            , datumPair . Datum $ toBuiltinData stakeDatum
+            ]
+        , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
+        }
+
+--------------------------------------------------------------------------------
+
+-- | Parameters for creating a voting transaction.
+data VotingParameters = VotingParameters
+  { voteFor :: ResultTag
+  -- ^ The outcome the transaction is voting for.
+  , voteCount :: Integer
+  -- ^ The count of votes.
+  }
+
+-- | Create a valid transaction that votes on a propsal, given the parameters.
+voteOnProposal :: VotingParameters -> TxInfo
+voteOnProposal params =
+  let pst = Value.singleton proposalPolicySymbol "" 1
+      sst = Value.assetClassValue stakeAssetClass 1
+
+      ---
+
+      stakeOwner = signer
+
+      ---
+
+      effects =
+        AssocMap.fromList
+          [ (ResultTag 0, AssocMap.empty)
+          , (ResultTag 1, AssocMap.empty)
+          ]
+
+      ---
+
+      initialVotes :: AssocMap.Map ResultTag Integer
+      initialVotes =
+        AssocMap.fromList
+          [ (ResultTag 0, 42)
+          , (ResultTag 1, 4242)
+          ]
+
+      ---
+
+      proposalInputDatum' :: ProposalDatum
+      proposalInputDatum' =
+        ProposalDatum
+          { proposalId = ProposalId 42
+          , effects = effects
+          , status = VotingReady
+          , cosigners = [stakeOwner]
+          , thresholds = def
+          , votes = ProposalVotes initialVotes
+          , timingConfig = def
+          , startingTime = ProposalStartingTime 0
+          }
+      proposalInputDatum :: Datum
+      proposalInputDatum = Datum $ toBuiltinData proposalInputDatum'
+      proposalInput :: TxOut
+      proposalInput =
+        TxOut
+          { txOutAddress = proposalValidatorAddress
+          , txOutValue = pst
+          , txOutDatumHash = Just $ toDatumHash proposalInputDatum
+          }
+
+      ---
+
+      existingLocks :: [ProposalLock]
+      existingLocks =
+        [ ProposalLock (ResultTag 0) (ProposalId 0)
+        , ProposalLock (ResultTag 2) (ProposalId 1)
+        ]
+
+      ---
+
+      stakeInputDatum' :: StakeDatum
+      stakeInputDatum' =
+        StakeDatum
+          { stakedAmount = Tagged params.voteCount
+          , owner = stakeOwner
+          , lockedBy = existingLocks
+          }
+      stakeInputDatum :: Datum
+      stakeInputDatum = Datum $ toBuiltinData stakeInputDatum'
+      stakeInput :: TxOut
+      stakeInput =
+        TxOut
+          { txOutAddress = stakeAddress
+          , txOutValue =
+              mconcat
+                [ sst
+                , Value.assetClassValue (untag stake.gtClassRef) params.voteCount
+                , minAda
+                ]
+          , txOutDatumHash = Just $ toDatumHash stakeInputDatum
+          }
+
+      ---
+
+      updatedVotes :: AssocMap.Map ResultTag Integer
+      updatedVotes = updateMap (Just . (+ params.voteCount)) params.voteFor initialVotes
+
+      ---
+
+      proposalOutputDatum' :: ProposalDatum
+      proposalOutputDatum' =
+        proposalInputDatum'
+          { votes = ProposalVotes updatedVotes
+          }
+      proposalOutputDatum :: Datum
+      proposalOutputDatum = Datum $ toBuiltinData proposalOutputDatum'
+      proposalOutput :: TxOut
+      proposalOutput =
+        proposalInput
+          { txOutDatumHash = Just $ toDatumHash proposalOutputDatum
+          }
+
+      ---
+
+      -- Off-chain code should do exactly like this: prepend new lock toStatus the list.
+      updatedLocks :: [ProposalLock]
+      updatedLocks = ProposalLock params.voteFor proposalInputDatum'.proposalId : existingLocks
+
+      ---
+
+      stakeOutputDatum' :: StakeDatum
+      stakeOutputDatum' =
+        stakeInputDatum'
+          { lockedBy = updatedLocks
+          }
+      stakeOutputDatum :: Datum
+      stakeOutputDatum = Datum $ toBuiltinData stakeOutputDatum'
+      stakeOutput :: TxOut
+      stakeOutput =
+        stakeInput
+          { txOutDatumHash = Just $ toDatumHash stakeOutputDatum
+          }
+
+      ---
+
+      validTimeRange =
+        closedBoundedInterval
+          ((def :: ProposalTimingConfig).draftTime + 1)
+          ((def :: ProposalTimingConfig).votingTime - 1)
+   in TxInfo
+        { txInfoInputs =
+            [ TxInInfo proposalRef proposalInput
+            , TxInInfo stakeRef stakeInput
+            ]
+        , txInfoOutputs = [proposalOutput, stakeOutput]
+        , txInfoFee = Value.singleton "" "" 2
+        , txInfoMint = mempty
+        , txInfoDCert = []
+        , txInfoWdrl = []
+        , txInfoValidRange = validTimeRange
+        , txInfoSignatories = [stakeOwner]
+        , txInfoData = datumPair <$> [proposalInputDatum, proposalOutputDatum, stakeInputDatum, stakeOutputDatum]
+        , txInfoId = "827598fb2d69a896bbd9e645bb14c307df907f422b39eecbe4d6329bc30b428c"
+        }
+
+--------------------------------------------------------------------------------
+
+-- | Parameters for state transition of proposals.
+data TransitionParameters = TransitionParameters
+  { -- The initial status of the propsoal.
+  initialProposalStatus :: ProposalStatus
+  , -- The starting time of the propsoal.
+  proposalStartingTime :: ProposalStartingTime
+  }
+
+-- | Create a 'TxInfo' that update the status of a proposal.
+mkTransitionTxInfo ::
+  -- | Initial state of the proposal.
+  ProposalStatus ->
+  -- | Next state of the proposal.
+  ProposalStatus ->
+  -- | Effects.
+  AssocMap.Map ResultTag (AssocMap.Map ValidatorHash DatumHash) ->
+  -- | Votes.
+  ProposalVotes ->
+  -- | Starting time of the proposal.
+  ProposalStartingTime ->
+  -- | Valid time range of the transaction.
+  POSIXTimeRange ->
+  TxInfo
+mkTransitionTxInfo from to effects votes startingTime timeRange =
+  let pst = Value.singleton proposalPolicySymbol "" 1
+
+      ---
+
+      proposalInputDatum' :: ProposalDatum
+      proposalInputDatum' =
+        ProposalDatum
+          { proposalId = ProposalId 0
+          , effects = effects
+          , status = from
+          , cosigners = [signer]
+          , thresholds = def
+          , votes = votes
+          , timingConfig = def
+          , startingTime = startingTime
+          }
+      proposalInputDatum :: Datum
+      proposalInputDatum = Datum $ toBuiltinData proposalInputDatum'
+      proposalInput :: TxOut
+      proposalInput =
+        TxOut
+          { txOutAddress = proposalValidatorAddress
+          , txOutValue = pst
+          , txOutDatumHash = Just $ toDatumHash proposalInputDatum
+          }
+
+      ---
+
+      proposalOutputDatum' :: ProposalDatum
+      proposalOutputDatum' =
+        proposalInputDatum'
+          { status = to
+          }
+      proposalOutputDatum :: Datum
+      proposalOutputDatum = Datum $ toBuiltinData proposalOutputDatum'
+      proposalOutput :: TxOut
+      proposalOutput =
+        proposalInput
+          { txOutValue = proposalInput.txOutValue <> minAda
+          , txOutDatumHash = Just $ toDatumHash proposalOutputDatum
+          }
+   in TxInfo
+        { txInfoInputs = [TxInInfo proposalRef proposalInput]
+        , txInfoOutputs = [proposalOutput]
+        , txInfoFee = Value.singleton "" "" 2
+        , txInfoMint = mempty
+        , txInfoDCert = []
+        , txInfoWdrl = []
+        , txInfoValidRange = timeRange
+        , txInfoSignatories = [signer]
+        , txInfoData = datumPair <$> [proposalInputDatum, proposalOutputDatum]
+        , txInfoId = "95ba4015e30aef16a3461ea97a779f814aeea6b8009d99a94add4b8293be737a"
+        }
+
+{- | Create a valid 'TxInfo' that advances a proposal, given the parameters.
+     Note that 'TransitionParameters.initialProposalStatus' should not be 'Finished'.
+-}
+advanceProposalSuccess :: TransitionParameters -> TxInfo
+advanceProposalSuccess params =
+  let -- Status of the output proposal.
+      toStatus :: ProposalStatus
+      toStatus = case params.initialProposalStatus of
+        Draft -> VotingReady
+        VotingReady -> Locked
+        Locked -> Finished
+        Finished -> error "Cannot advance 'Finished' proposal"
+
+      effects =
+        AssocMap.fromList
+          [ (ResultTag 0, AssocMap.empty)
+          , (ResultTag 1, AssocMap.empty)
+          ]
+
+      emptyVotes@(ProposalVotes emptyVotes') = emptyVotesFor effects
+
+      -- Set the vote count of outcome 0 to @def.countingVoting + 1@,
+      --   meaning that outcome 0 will be the winner.
+      outcome0WinningVotes =
+        ProposalVotes $
+          updateMap
+            (\_ -> Just $ untag (def :: ProposalThresholds).countVoting + 1)
+            (ResultTag 0)
+            emptyVotes'
+
+      votes :: ProposalVotes
+      votes = case params.initialProposalStatus of
+        Draft -> emptyVotes
+        -- With sufficient votes
+        _ -> outcome0WinningVotes
+
+      proposalStartingTime :: POSIXTime
+      proposalStartingTime =
+        let (ProposalStartingTime startingTime) = params.proposalStartingTime
+         in startingTime
+
+      timeRange :: POSIXTimeRange
+      timeRange = case params.initialProposalStatus of
+        -- [S + 1, S + D - 1]
+        Draft ->
+          closedBoundedInterval
+            (proposalStartingTime + 1)
+            (proposalStartingTime + (def :: ProposalTimingConfig).draftTime - 1)
+        -- [S + D + V + 1, S + D + V + L - 1]
+        VotingReady ->
+          closedBoundedInterval
+            ( proposalStartingTime
+                + (def :: ProposalTimingConfig).draftTime
+                + (def :: ProposalTimingConfig).votingTime
+                + 1
+            )
+            ( proposalStartingTime
+                + (def :: ProposalTimingConfig).draftTime
+                + (def :: ProposalTimingConfig).votingTime
+                + (def :: ProposalTimingConfig).lockingTime
+                - 1
+            )
+        -- [S + D + V + L + 1, S + + D + V + L + E - 1]
+        Locked ->
+          closedBoundedInterval
+            ( proposalStartingTime
+                + (def :: ProposalTimingConfig).draftTime
+                + (def :: ProposalTimingConfig).votingTime
+                + (def :: ProposalTimingConfig).lockingTime
+                + 1
+            )
+            ( proposalStartingTime
+                + (def :: ProposalTimingConfig).draftTime
+                + (def :: ProposalTimingConfig).votingTime
+                + (def :: ProposalTimingConfig).lockingTime
+                + (def :: ProposalTimingConfig).executingTime - 1
+            )
+        Finished -> error "Cannot advance 'Finished' proposal"
+   in mkTransitionTxInfo
+        params.initialProposalStatus
+        toStatus
+        effects
+        votes
+        params.proposalStartingTime
+        timeRange
+
+{- | Create a valid 'TxInfo' that advances a proposal to failed state, given the parameters.
+     The reason why the proposal fails is the proposal has ran out of time.
+     Note that 'TransitionParameters.initialProposalStatus' should not be 'Finished'.
+-}
+advanceProposalFailureTimeout :: TransitionParameters -> TxInfo
+advanceProposalFailureTimeout params =
+  let effects =
+        AssocMap.fromList
+          [ (ResultTag 0, AssocMap.empty)
+          , (ResultTag 1, AssocMap.empty)
+          ]
+
+      emptyVotes@(ProposalVotes emptyVotes') = emptyVotesFor effects
+
+      -- Set the vote count of outcome 0 to @def.countingVoting + 1@,
+      --   meaning that outcome 0 will be the winner.
+      outcome0WinningVotes =
+        ProposalVotes $
+          updateMap
+            (\_ -> Just $ untag (def :: ProposalThresholds).countVoting + 1)
+            (ResultTag 0)
+            emptyVotes'
+
+      votes :: ProposalVotes
+      votes = case params.initialProposalStatus of
+        Draft -> emptyVotes
+        -- With sufficient votes
+        _ -> outcome0WinningVotes
+
+      proposalStartingTime :: POSIXTime
+      proposalStartingTime =
+        let (ProposalStartingTime startingTime) = params.proposalStartingTime
+         in startingTime
+
+      timeRange :: POSIXTimeRange
+      timeRange = case params.initialProposalStatus of
+        -- [S + D + 1, S + D + V - 1]
+        Draft ->
+          closedBoundedInterval
+            (proposalStartingTime + (def :: ProposalTimingConfig).draftTime + 1)
+            ( proposalStartingTime
+                + (def :: ProposalTimingConfig).draftTime
+                + (def :: ProposalTimingConfig).votingTime - 1
+            )
+        -- [S + D + V + L + 1, S + D + V + L + E -1]
+        VotingReady ->
+          closedBoundedInterval
+            ( proposalStartingTime
+                + (def :: ProposalTimingConfig).draftTime
+                + (def :: ProposalTimingConfig).votingTime
+                + (def :: ProposalTimingConfig).lockingTime
+                + 1
+            )
+            ( proposalStartingTime
+                + (def :: ProposalTimingConfig).draftTime
+                + (def :: ProposalTimingConfig).votingTime
+                + (def :: ProposalTimingConfig).lockingTime
+                + (def :: ProposalTimingConfig).executingTime
+                - 1
+            )
+        -- [S + D + V + L + E + 1, S + D + V + L + E + 100]
+        Locked ->
+          closedBoundedInterval
+            ( proposalStartingTime
+                + (def :: ProposalTimingConfig).draftTime
+                + (def :: ProposalTimingConfig).votingTime
+                + (def :: ProposalTimingConfig).lockingTime
+                + (def :: ProposalTimingConfig).executingTime
+                + 1
+            )
+            ( proposalStartingTime
+                + (def :: ProposalTimingConfig).draftTime
+                + (def :: ProposalTimingConfig).votingTime
+                + (def :: ProposalTimingConfig).lockingTime
+                + (def :: ProposalTimingConfig).executingTime
+                + 100
+            )
+        Finished -> error "Cannot advance 'Finished' proposal"
+   in mkTransitionTxInfo
+        params.initialProposalStatus
+        Finished
+        effects
+        votes
+        params.proposalStartingTime
+        timeRange
+
+-- | An invalid 'TxInfo' that tries to advance a 'VotingReady' proposal without sufficient votes.
+advanceProposalInsufficientVotes :: TxInfo
+advanceProposalInsufficientVotes =
+  let effects =
+        AssocMap.fromList
+          [ (ResultTag 0, AssocMap.empty)
+          , (ResultTag 1, AssocMap.empty)
+          ]
+
+      -- Insufficient votes.
+      votes = emptyVotesFor effects
+
+      proposalStartingTime = 0
+
+      -- Valid time range.
+      -- [S + D + 1, S + V - 1]
+      timeRange =
+        closedBoundedInterval
+          (proposalStartingTime + (def :: ProposalTimingConfig).draftTime + 1)
+          (proposalStartingTime + (def :: ProposalTimingConfig).votingTime - 1)
+   in mkTransitionTxInfo
+        VotingReady
+        Locked
+        effects
+        votes
+        (ProposalStartingTime proposalStartingTime)
+        timeRange
+
+-- | An invalid 'TxInfo' that tries to advance a 'Finished' proposal.
+advanceFinishedPropsoal :: TxInfo
+advanceFinishedPropsoal =
+  let effects =
+        AssocMap.fromList
+          [ (ResultTag 0, AssocMap.empty)
+          , (ResultTag 1, AssocMap.empty)
+          ]
+
+      -- Set the vote count of outcome 0 to @def.countingVoting + 1@,
+      --   meaning that outcome 0 will be the winner.
+      outcome0WinningVotes =
+        ProposalVotes $
+          AssocMap.fromList
+            [ (ResultTag 0, untag (def :: ProposalThresholds).countVoting + 1)
+            , (ResultTag 1, 0)
+            ]
+
+      ---
+
+      timeRange =
+        closedBoundedInterval
+          ((def :: ProposalTimingConfig).lockingTime + 1)
+          ((def :: ProposalTimingConfig).executingTime - 1)
+   in mkTransitionTxInfo
+        Finished
+        Finished
+        effects
+        outcome0WinningVotes
+        (ProposalStartingTime 0)
+        timeRange
+
+{- | An illegal 'TxInfo' that tries to use 'AdvanceProposal' with a stake.
+     From the perspective of stake validator, the transition is valid,
+       so the proposal validator should reject this.
+-}
+advancePropsoalWithsStake :: TxInfo
+advancePropsoalWithsStake =
+  let templateTxInfo =
+        advanceProposalSuccess
+          TransitionParameters
+            { initialProposalStatus = VotingReady
+            , proposalStartingTime = ProposalStartingTime 0
+            }
+
+      ---
+      -- Now we create a new lock on an arbitrary stake
+
+      sst = Value.assetClassValue stakeAssetClass 1
+
+      ---
+
+      stakeOwner = signer
+      stakedAmount = 200
+
+      ---
+
+      existingLocks :: [ProposalLock]
+      existingLocks =
+        [ ProposalLock (ResultTag 0) (ProposalId 0)
+        , ProposalLock (ResultTag 2) (ProposalId 1)
+        ]
+
+      ---
+
+      stakeInputDatum' :: StakeDatum
+      stakeInputDatum' =
+        StakeDatum
+          { stakedAmount = Tagged stakedAmount
+          , owner = stakeOwner
+          , lockedBy = existingLocks
+          }
+      stakeInputDatum :: Datum
+      stakeInputDatum = Datum $ toBuiltinData stakeInputDatum'
+      stakeInput :: TxOut
+      stakeInput =
+        TxOut
+          { txOutAddress = stakeAddress
+          , txOutValue =
+              mconcat
+                [ sst
+                , Value.assetClassValue (untag stake.gtClassRef) stakedAmount
+                , minAda
+                ]
+          , txOutDatumHash = Just $ toDatumHash stakeInputDatum
+          }
+
+      ---
+
+      updatedLocks :: [ProposalLock]
+      updatedLocks = ProposalLock (ResultTag 42) (ProposalId 27) : existingLocks
+
+      ---
+
+      stakeOutputDatum' :: StakeDatum
+      stakeOutputDatum' =
+        stakeInputDatum'
+          { lockedBy = updatedLocks
+          }
+      stakeOutputDatum :: Datum
+      stakeOutputDatum = Datum $ toBuiltinData stakeOutputDatum'
+      stakeOutput :: TxOut
+      stakeOutput =
+        stakeInput
+          { txOutDatumHash = Just $ toDatumHash stakeOutputDatum
+          }
+   in templateTxInfo
+        { txInfoInputs = TxInInfo stakeRef stakeInput : templateTxInfo.txInfoInputs
+        , txInfoOutputs = stakeOutput : templateTxInfo.txInfoOutputs
+        , txInfoData =
+            (datumPair <$> [stakeInputDatum, stakeOutputDatum])
+              <> templateTxInfo.txInfoData
+        , txInfoSignatories = [stakeOwner]
+        }

agora-specs/Sample/Shared.hs

@@ -0,0 +1,272 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+{- |
+Module     : Sample.Shared
+Maintainer : emi@haskell.fyi
+Description: Shared useful values for creating Samples for testing.
+
+Shared useful values for creating Samples for testing.
+-}
+module Sample.Shared (
+  -- * Misc
+  signer,
+  signer2,
+  minAda,
+
+  -- * Components
+
+  -- ** Stake
+  stake,
+  stakeAssetClass,
+  stakeValidatorHash,
+  stakeAddress,
+  stakeSymbol,
+
+  -- ** Governor
+  governor,
+  govPolicy,
+  govValidator,
+  govSymbol,
+  govAssetClass,
+  govValidatorAddress,
+  govValidatorHash,
+  gstUTXORef,
+
+  -- ** Proposal
+  proposal,
+  proposalPolicySymbol,
+  proposalValidatorHash,
+  proposalValidatorAddress,
+  proposalStartingTimeFromTimeRange,
+
+  -- ** Authority
+  authorityToken,
+  authorityTokenSymbol,
+
+  -- ** Treasury
+  treasuryOut,
+  gatTn,
+  gatCs,
+  mockTrEffect,
+  trCredential,
+  wrongEffHash,
+) where
+
+import Agora.AuthorityToken
+import Agora.Effect.NoOp (noOpValidator)
+import Agora.Governor (
+  Governor (Governor),
+ )
+import Agora.Governor.Scripts (
+  authorityTokenFromGovernor,
+  authorityTokenSymbolFromGovernor,
+  governorPolicy,
+  governorSTAssetClassFromGovernor,
+  governorValidator,
+  governorValidatorHash,
+  proposalFromGovernor,
+  proposalSTSymbolFromGovernor,
+  proposalValidatorHashFromGovernor,
+  stakeFromGovernor,
+  stakeSTAssetClassFromGovernor,
+  stakeSTSymbolFromGovernor,
+  stakeValidatorHashFromGovernor,
+ )
+import Agora.Proposal (
+  Proposal (..),
+  ProposalThresholds (..),
+ )
+import Agora.Proposal.Time (
+  MaxTimeRangeWidth (..),
+  ProposalStartingTime (ProposalStartingTime),
+  ProposalTimingConfig (..),
+ )
+import Agora.Stake (Stake (..))
+import Agora.Treasury (treasuryValidator)
+import Agora.Utils (validatorHashToTokenName)
+import Data.Default.Class (Default (..))
+import Data.Tagged (Tagged (..))
+import Plutarch.Api.V1 (
+  mintingPolicySymbol,
+  mkMintingPolicy,
+  mkValidator,
+  validatorHash,
+ )
+import Plutus.V1.Ledger.Address (scriptHashAddress)
+import Plutus.V1.Ledger.Api (
+  Address (Address),
+  Credential (ScriptCredential),
+  CurrencySymbol,
+  Extended (..),
+  Interval (..),
+  LowerBound (..),
+  MintingPolicy (..),
+  POSIXTimeRange,
+  PubKeyHash,
+  TxOutRef (TxOutRef),
+  UpperBound (..),
+  Value,
+ )
+import Plutus.V1.Ledger.Contexts (
+  TxOut (..),
+ )
+import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash (..))
+import Plutus.V1.Ledger.Value (AssetClass, TokenName)
+import Plutus.V1.Ledger.Value qualified as Value
+
+--------------------------------------------------------------------------------
+
+stake :: Stake
+stake = stakeFromGovernor governor
+
+stakeSymbol :: CurrencySymbol
+stakeSymbol = stakeSTSymbolFromGovernor governor
+
+stakeAssetClass :: AssetClass
+stakeAssetClass = stakeSTAssetClassFromGovernor governor
+
+stakeValidatorHash :: ValidatorHash
+stakeValidatorHash = stakeValidatorHashFromGovernor governor
+
+stakeAddress :: Address
+stakeAddress = Address (ScriptCredential stakeValidatorHash) Nothing
+
+gstUTXORef :: TxOutRef
+gstUTXORef = TxOutRef "f28cd7145c24e66fd5bcd2796837aeb19a48a2656e7833c88c62a2d0450bd00d" 0
+
+governor :: Governor
+governor = Governor oref gt mc
+  where
+    oref = gstUTXORef
+    gt =
+      Tagged $
+        Value.assetClass
+          "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
+          "LQ"
+    mc = 6
+
+govPolicy :: MintingPolicy
+govPolicy = mkMintingPolicy (governorPolicy governor)
+
+govValidator :: Validator
+govValidator = mkValidator (governorValidator governor)
+
+govSymbol :: CurrencySymbol
+govSymbol = mintingPolicySymbol govPolicy
+
+govAssetClass :: AssetClass
+govAssetClass = governorSTAssetClassFromGovernor governor
+
+govValidatorHash :: ValidatorHash
+govValidatorHash = governorValidatorHash governor
+
+govValidatorAddress :: Address
+govValidatorAddress = scriptHashAddress govValidatorHash
+
+proposal :: Proposal
+proposal = proposalFromGovernor governor
+
+proposalPolicySymbol :: CurrencySymbol
+proposalPolicySymbol = proposalSTSymbolFromGovernor governor
+
+-- | A sample 'PubKeyHash'.
+signer :: PubKeyHash
+signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
+
+-- | Another sample 'PubKeyHash'.
+signer2 :: PubKeyHash
+signer2 = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be74012141420192"
+
+proposalValidatorHash :: ValidatorHash
+proposalValidatorHash = proposalValidatorHashFromGovernor governor
+
+proposalValidatorAddress :: Address
+proposalValidatorAddress = scriptHashAddress proposalValidatorHash
+
+{- | Default value of 'Agora.Proposal.ProposalThresholds'.
+     For testing purpose only.
+-}
+instance Default ProposalThresholds where
+  def =
+    ProposalThresholds
+      { countVoting = Tagged 1000
+      , create = Tagged 1
+      , startVoting = Tagged 10
+      }
+
+authorityToken :: AuthorityToken
+authorityToken = authorityTokenFromGovernor governor
+
+authorityTokenSymbol :: CurrencySymbol
+authorityTokenSymbol = authorityTokenSymbolFromGovernor governor
+
+{- | Default value of 'Agora.Governor.GovernorDatum.proposalTimings'.
+     For testing purpose only.
+-}
+instance Default ProposalTimingConfig where
+  def =
+    ProposalTimingConfig
+      { draftTime = 50
+      , votingTime = 1000
+      , lockingTime = 2000
+      , executingTime = 3000
+      }
+
+{- | Default value of 'Agora.Governor.GovernorDatum.createProposalTimeRangeMaxWidth'.
+     For testing purpose only.
+-}
+instance Default MaxTimeRangeWidth where
+  def = MaxTimeRangeWidth 10
+
+{- | Get the starting time of a proposal, given a closed finite time range.
+     Tightness of the time range is not checked. See 'Agora.Proposal.Time.createProposalStartingTime'.
+-}
+proposalStartingTimeFromTimeRange :: POSIXTimeRange -> ProposalStartingTime
+proposalStartingTimeFromTimeRange
+  (Interval (LowerBound (Finite l) True) (UpperBound (Finite u) True)) =
+    ProposalStartingTime $ (l + u) `div` 2
+proposalStartingTimeFromTimeRange _ = error "Given time range should be finite and closed"
+
+------------------------------------------------------------------
+
+treasuryOut :: TxOut
+treasuryOut =
+  TxOut
+    { txOutAddress = Address trCredential Nothing
+    , txOutValue = minAda
+    , txOutDatumHash = Nothing
+    }
+
+{- | Arbitrary 'CurrencySymbol', representing the 'CurrencySymbol'
+     of a valid governance authority token (GAT).
+-}
+gatCs :: CurrencySymbol
+gatCs = "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
+
+trValidator :: Validator
+trValidator = mkValidator (treasuryValidator gatCs)
+
+-- | `ScriptCredential` used for the dummy treasury validator.
+trCredential :: Credential
+trCredential = ScriptCredential $ validatorHash trValidator
+
+-- | `TokenName` for GAT generated from address of `mockTrEffect`.
+gatTn :: TokenName
+gatTn = validatorHashToTokenName $ validatorHash mockTrEffect
+
+-- | Mock treasury effect script, used for testing.
+mockTrEffect :: Validator
+mockTrEffect = mkValidator $ noOpValidator gatCs
+
+{- | A SHA-256 hash which (in all certainty) should not match the
+     hash of the dummy effect script.
+-}
+wrongEffHash :: ValidatorHash
+wrongEffHash =
+  ValidatorHash
+    "a21bc4a1d95600f9fa0a00b97ed0fa49a152a72de76253cb706f90b4b40f837b"
+
+------------------------------------------------------------------
+
+minAda :: Value
+minAda = Value.singleton "" "" 10_000_000

agora-specs/Sample/Stake.hs

@@ -0,0 +1,162 @@
+{- |
+Module     : Sample.Stake
+Maintainer : emi@haskell.fyi
+Description: Sample based testing for Stake utxos
+
+This module tests primarily the happy path for Stake creation
+-}
+module Sample.Stake (
+  stake,
+  stakeAssetClass,
+  stakeSymbol,
+  validatorHashTN,
+  signer,
+
+  -- * Script contexts
+  stakeCreation,
+  stakeCreationWrongDatum,
+  stakeCreationUnsigned,
+  stakeDepositWithdraw,
+  DepositWithdrawExample (..),
+) where
+
+--------------------------------------------------------------------------------
+import Plutarch.Api.V1 (
+  mkValidator,
+  validatorHash,
+ )
+import Plutus.V1.Ledger.Api (
+  Address (Address),
+  Credential (ScriptCredential),
+  Datum (Datum),
+  DatumHash (DatumHash),
+  ScriptContext (..),
+  ScriptPurpose (..),
+  ToData (toBuiltinData),
+  TxInInfo (TxInInfo),
+  TxInfo (..),
+  TxOut (txOutAddress, txOutDatumHash, txOutValue),
+  ValidatorHash (ValidatorHash),
+ )
+import Plutus.V1.Ledger.Contexts (TxOut (TxOut), TxOutRef (TxOutRef))
+import Plutus.V1.Ledger.Interval qualified as Interval
+import Plutus.V1.Ledger.Value (TokenName (TokenName))
+import Plutus.V1.Ledger.Value qualified as Value
+
+--------------------------------------------------------------------------------
+
+import Agora.SafeMoney (GTTag)
+import Agora.Stake
+import Agora.Stake.Scripts (stakeValidator)
+import Data.Tagged (Tagged (..), untag)
+import Sample.Shared
+import Test.Util (datumPair, toDatumHash)
+
+--------------------------------------------------------------------------------
+
+-- | 'TokenName' that represents the hash of the 'Stake' validator.
+validatorHashTN :: TokenName
+validatorHashTN = let ValidatorHash vh = validatorHash (mkValidator $ stakeValidator stake) in TokenName vh
+
+-- | This script context should be a valid transaction.
+stakeCreation :: ScriptContext
+stakeCreation =
+  let st = Value.assetClassValue stakeAssetClass 1 -- Stake ST
+      datum :: Datum
+      datum = Datum (toBuiltinData $ StakeDatum 424242424242 signer [])
+   in ScriptContext
+        { scriptContextTxInfo =
+            TxInfo
+              { txInfoInputs = []
+              , txInfoOutputs =
+                  [ TxOut
+                      { txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing
+                      , txOutValue = st <> Value.singleton "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" "LQ" 424242424242
+                      , txOutDatumHash = Just (DatumHash "")
+                      }
+                  ]
+              , txInfoFee = Value.singleton "" "" 2
+              , txInfoMint = st
+              , txInfoDCert = []
+              , txInfoWdrl = []
+              , txInfoValidRange = Interval.always
+              , txInfoSignatories = [signer]
+              , txInfoData = [("", datum)]
+              , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
+              }
+        , scriptContextPurpose = Minting stakeSymbol
+        }
+
+-- | This ScriptContext should fail because the datum has too much GT.
+stakeCreationWrongDatum :: ScriptContext
+stakeCreationWrongDatum =
+  let datum :: Datum
+      datum = Datum (toBuiltinData $ StakeDatum 4242424242424242 signer []) -- Too much GT
+   in ScriptContext
+        { scriptContextTxInfo = stakeCreation.scriptContextTxInfo {txInfoData = [("", datum)]}
+        , scriptContextPurpose = Minting stakeSymbol
+        }
+
+-- | This ScriptContext should fail because the datum has too much GT.
+stakeCreationUnsigned :: ScriptContext
+stakeCreationUnsigned =
+  ScriptContext
+    { scriptContextTxInfo =
+        stakeCreation.scriptContextTxInfo
+          { txInfoSignatories = []
+          }
+    , scriptContextPurpose = Minting stakeSymbol
+    }
+
+--------------------------------------------------------------------------------
+
+-- | Config for creating a ScriptContext that deposits or withdraws.
+data DepositWithdrawExample = DepositWithdrawExample
+  { startAmount :: Tagged GTTag Integer
+  -- ^ The amount of GT stored before the transaction.
+  , delta :: Tagged GTTag Integer
+  -- ^ The amount of GT deposited or withdrawn from the Stake.
+  }
+
+-- | Create a ScriptContext that deposits or withdraws, given the config for it.
+stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext
+stakeDepositWithdraw config =
+  let st = Value.assetClassValue stakeAssetClass 1 -- Stake ST
+      stakeBefore :: StakeDatum
+      stakeBefore = StakeDatum config.startAmount signer []
+
+      stakeAfter :: StakeDatum
+      stakeAfter = stakeBefore {stakedAmount = stakeBefore.stakedAmount + config.delta}
+   in ScriptContext
+        { scriptContextTxInfo =
+            TxInfo
+              { txInfoInputs =
+                  [ TxInInfo
+                      (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+                      TxOut
+                        { txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing
+                        , txOutValue =
+                            st
+                              <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount)
+                        , txOutDatumHash = Just (toDatumHash stakeAfter)
+                        }
+                  ]
+              , txInfoOutputs =
+                  [ TxOut
+                      { txOutAddress = Address (ScriptCredential stakeValidatorHash) Nothing
+                      , txOutValue =
+                          st <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount)
+                      , txOutDatumHash = Just (toDatumHash stakeAfter)
+                      }
+                  ]
+              , txInfoFee = Value.singleton "" "" 2
+              , txInfoMint = st
+              , txInfoDCert = []
+              , txInfoWdrl = []
+              , txInfoValidRange = Interval.always
+              , txInfoSignatories = [signer]
+              , txInfoData = [datumPair stakeAfter]
+              , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
+              }
+        , scriptContextPurpose = Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+        }

agora-specs/Sample/Treasury.hs

@@ -0,0 +1,163 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+{- |
+Module: Sample.Treasury
+Description: Sample data for `Spec.Treasury`.
+Maintainer: jack@mlabs.city
+
+This module contains sample data, used in the tests written in
+`Spec.Treasury`.
+-}
+module Sample.Treasury (
+  gatCs,
+  validCtx,
+  treasuryRef,
+  gatTn,
+  walletIn,
+  trCtxGATNameNotAddress,
+) where
+
+import Plutarch.Api.V1 (validatorHash)
+import Plutus.V1.Ledger.Address (Address (..))
+import Plutus.V1.Ledger.Api (
+  BuiltinByteString,
+  Credential (PubKeyCredential),
+  PubKeyHash (PubKeyHash),
+ )
+import Plutus.V1.Ledger.Contexts (
+  ScriptContext (..),
+  ScriptPurpose (Minting),
+  TxInInfo (..),
+  TxInfo (..),
+  TxOut (..),
+  TxOutRef (..),
+ )
+import Plutus.V1.Ledger.Credential (Credential (ScriptCredential))
+import Plutus.V1.Ledger.Interval qualified as Interval
+import Plutus.V1.Ledger.Scripts (
+  ValidatorHash (ValidatorHash),
+ )
+import Plutus.V1.Ledger.Value qualified as Value
+import Sample.Shared (
+  gatCs,
+  gatTn,
+  minAda,
+  mockTrEffect,
+  signer,
+  treasuryOut,
+  wrongEffHash,
+ )
+import Test.Util (datumPair)
+
+{- | A `ScriptContext` that should be compatible with treasury
+     transactions.
+-}
+validCtx :: ScriptContext
+validCtx =
+  ScriptContext
+    { scriptContextPurpose = Minting gatCs
+    , scriptContextTxInfo =
+        TxInfo
+          { txInfoInputs =
+              [ treasuryIn
+              , effectIn
+              ]
+          , txInfoOutputs =
+              [ treasuryOut
+              ]
+          , -- Ensure sufficient ADA for transaction costs.
+            txInfoFee = Value.singleton "" "" 2 -- 2 ADA.
+          , -- Burn the GAT.
+            txInfoMint = Value.singleton gatCs gatTn (-1)
+          , txInfoDCert = []
+          , txInfoWdrl = []
+          , txInfoValidRange = Interval.always
+          , txInfoSignatories = [signer]
+          , txInfoData =
+              [ datumPair treasuryIn
+              , datumPair treasuryOut
+              , datumPair effectIn
+              ]
+          , txInfoId =
+              "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
+          }
+    }
+  where
+    treasuryIn =
+      TxInInfo
+        { txInInfoOutRef = treasuryRef
+        , txInInfoResolved = treasuryOut
+        }
+    effectIn =
+      TxInInfo
+        { txInInfoOutRef = effectRef
+        , txInInfoResolved =
+            TxOut
+              { txOutAddress =
+                  Address (ScriptCredential $ validatorHash mockTrEffect) Nothing
+              , txOutValue =
+                  mconcat
+                    [ Value.singleton gatCs gatTn 1
+                    , minAda
+                    ]
+              , txOutDatumHash = Nothing
+              }
+        }
+
+-- | Reference to treasury output.
+treasuryRef :: TxOutRef
+treasuryRef =
+  TxOutRef
+    "73475cb40a568e8da8a045ced110137e159f890ac4da883b6b17dc651b3a8049"
+    1
+
+-- | Reference to dummy effect output.
+effectRef :: TxOutRef
+effectRef =
+  TxOutRef
+    "52b67b60260da3937510ad545c7f46f8d9915bd27e1082e76947fb309f913bd3"
+    0
+
+-- | Input representing a user wallet with a valid GAT.
+walletIn :: TxInInfo
+walletIn =
+  TxInInfo
+    { txInInfoOutRef =
+        TxOutRef
+          "cf4a8b33dd8e4493187e3339ecc3802d0cc000c947fb5559b7614153947d4e83"
+          0
+    , txInInfoResolved =
+        TxOut
+          { txOutDatumHash = Nothing
+          , txOutValue = Value.singleton gatCs gatTn 1
+          , txOutAddress =
+              Address
+                (PubKeyCredential $ PubKeyHash addressBs)
+                Nothing
+          }
+    }
+
+addressBs :: BuiltinByteString
+(ValidatorHash addressBs) = validatorHash mockTrEffect
+
+trCtxGATNameNotAddress :: ScriptContext
+trCtxGATNameNotAddress =
+  let txInfo = validCtx.scriptContextTxInfo
+      inputs = txInfo.txInfoInputs
+      effectIn = inputs !! 1
+      invalidEff =
+        effectIn
+          { txInInfoResolved =
+              effectIn.txInInfoResolved
+                { txOutAddress = Address (ScriptCredential wrongEffHash) Nothing
+                }
+          }
+   in validCtx
+        { scriptContextTxInfo =
+            txInfo
+              { txInfoInputs =
+                  [ head inputs
+                  , invalidEff
+                  ]
+              }
+        }