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
+                  ]
+              }
+        }

agora-specs/Spec/AuthorityToken.hs

@@ -0,0 +1,158 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+{- |
+Module     : Spec.AuthorityToken
+Maintainer : emi@haskell.fyi
+Description: Tests for Authority token functions
+
+Tests for Authority token functions
+-}
+module Spec.AuthorityToken (specs) where
+
+--------------------------------------------------------------------------------
+
+import Agora.AuthorityToken (singleAuthorityTokenBurned)
+import Plutarch
+import Prelude
+
+--------------------------------------------------------------------------------
+
+import Plutus.V1.Ledger.Api (
+  Address (Address),
+  Credential (PubKeyCredential, ScriptCredential),
+  CurrencySymbol,
+  Script,
+  TxInInfo (TxInInfo),
+  TxInfo (..),
+  TxOut (TxOut),
+  TxOutRef (TxOutRef),
+  ValidatorHash (ValidatorHash),
+  Value,
+ )
+import Plutus.V1.Ledger.Interval qualified as Interval
+import Plutus.V1.Ledger.Value qualified as Value
+import PlutusTx.AssocMap qualified as AssocMap
+import Test.Specification (
+  SpecificationTree,
+  group,
+  scriptFails,
+  scriptSucceeds,
+ )
+
+currencySymbol :: CurrencySymbol
+currencySymbol = "deadbeef"
+
+mkTxInfo :: Value -> [TxOut] -> TxInfo
+mkTxInfo mint outs =
+  TxInfo
+    { txInfoInputs = fmap (TxInInfo (TxOutRef "" 0)) outs
+    , txInfoOutputs = []
+    , txInfoFee = Value.singleton "" "" 1000
+    , txInfoMint = mint
+    , txInfoDCert = []
+    , txInfoWdrl = []
+    , txInfoValidRange = Interval.always
+    , txInfoSignatories = []
+    , txInfoData = []
+    , txInfoId = ""
+    }
+
+singleAuthorityTokenBurnedTest :: Value -> [TxOut] -> Script
+singleAuthorityTokenBurnedTest mint outs =
+  let actual :: ClosedTerm PBool
+      actual = singleAuthorityTokenBurned (pconstant currencySymbol) (pconstantData (mkTxInfo mint outs)) (pconstant mint)
+      s :: ClosedTerm POpaque
+      s =
+        pif
+          actual
+          (popaque (pconstant ()))
+          perror
+   in compile s
+
+specs :: [SpecificationTree]
+specs =
+  [ -- This is better suited for plutarch-test
+    group
+      "singleAuthorityTokenBurned"
+      [ scriptSucceeds
+          "Correct simple"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton currencySymbol "deadbeef" (-1)
+                  <> Value.singleton "aa" "USDC" 100_000
+              )
+              [ TxOut
+                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
+                  (Value.singleton currencySymbol "deadbeef" 1)
+                  Nothing
+              ]
+          )
+      , scriptSucceeds
+          "Correct many inputs"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton currencySymbol "deadbeef" (-1)
+                  <> Value.singleton "aa" "USDC" 100_000
+              )
+              [ TxOut
+                  (Address (PubKeyCredential "") Nothing)
+                  (Value.singleton "aaabcc" "hello-token" 1)
+                  Nothing
+              , TxOut
+                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
+                  (Value.singleton currencySymbol "deadbeef" 1)
+                  Nothing
+              , TxOut
+                  (Address (PubKeyCredential "") Nothing)
+                  (Value.singleton "" "" 1_000_000_000)
+                  Nothing
+              ]
+          )
+      , scriptFails
+          "Incorrect no burn"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.Value AssocMap.empty
+              )
+              []
+          )
+      , scriptFails
+          "Incorrect no GAT burn"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton "aabbcc" "not a GAT!" (-100)
+              )
+              []
+          )
+      , scriptFails
+          "Incorrect script mismatch"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton currencySymbol "i'm not deadbeef!" (-1)
+              )
+              [ TxOut
+                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
+                  (Value.singleton currencySymbol "i'm not deadbeef!" 1)
+                  Nothing
+              ]
+          )
+      , scriptFails
+          "Incorrect spent from PK"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton currencySymbol "doesn't matter" (-1)
+              )
+              [ TxOut
+                  (Address (PubKeyCredential "") Nothing)
+                  (Value.singleton currencySymbol "doesn't matter" 1)
+                  Nothing
+              ]
+          )
+      , scriptFails
+          "Incorrect two GATs"
+          ( singleAuthorityTokenBurnedTest
+              ( Value.singleton currencySymbol "deadbeef" (-2)
+                  <> Value.singleton "aa" "USDC" 100_000
+              )
+              [ TxOut
+                  (Address (ScriptCredential (ValidatorHash "deadbeef")) Nothing)
+                  (Value.singleton currencySymbol "deadbeef" 2)
+                  Nothing
+              ]
+          )
+      ]
+  ]

agora-specs/Spec/Effect/GovernorMutation.hs

@@ -0,0 +1,76 @@
+module Spec.Effect.GovernorMutation (specs) where
+
+import Agora.Effect.GovernorMutation (mutateGovernorValidator)
+import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor))
+import Agora.Governor.Scripts (governorValidator)
+import Agora.Proposal (ProposalId (..))
+import Data.Default.Class (Default (def))
+import Plutus.V1.Ledger.Api (ScriptContext (ScriptContext), ScriptPurpose (Spending))
+import Sample.Effect.GovernorMutation (
+  effectRef,
+  govRef,
+  invalidNewGovernorDatum,
+  mkEffectDatum,
+  mkEffectTxInfo,
+  validNewGovernorDatum,
+ )
+import Sample.Shared qualified as Shared
+import Test.Specification (
+  SpecificationTree,
+  effectFailsWith,
+  effectSucceedsWith,
+  group,
+  validatorFailsWith,
+  validatorSucceedsWith,
+ )
+
+specs :: [SpecificationTree]
+specs =
+  [ group
+      "validator"
+      [ group
+          "valid new governor datum"
+          [ validatorSucceedsWith
+              "governor validator should pass"
+              (governorValidator Shared.governor)
+              ( GovernorDatum
+                  def
+                  (ProposalId 0)
+                  def
+                  def
+              )
+              MutateGovernor
+              ( ScriptContext
+                  (mkEffectTxInfo validNewGovernorDatum)
+                  (Spending govRef)
+              )
+          , effectSucceedsWith
+              "effect validator should pass"
+              (mutateGovernorValidator Shared.governor)
+              (mkEffectDatum validNewGovernorDatum)
+              (ScriptContext (mkEffectTxInfo validNewGovernorDatum) (Spending effectRef))
+          ]
+      , group
+          "invalid new governor datum"
+          [ validatorFailsWith
+              "governor validator should fail"
+              (governorValidator Shared.governor)
+              ( GovernorDatum
+                  def
+                  (ProposalId 0)
+                  def
+                  def
+              )
+              MutateGovernor
+              ( ScriptContext
+                  (mkEffectTxInfo invalidNewGovernorDatum)
+                  (Spending govRef)
+              )
+          , effectFailsWith
+              "effect validator should fail"
+              (mutateGovernorValidator Shared.governor)
+              (mkEffectDatum validNewGovernorDatum)
+              (ScriptContext (mkEffectTxInfo invalidNewGovernorDatum) (Spending effectRef))
+          ]
+      ]
+  ]

agora-specs/Spec/Effect/TreasuryWithdrawal.hs

@@ -0,0 +1,172 @@
+{- |
+Module     : Spec.Effect.TreasuryWithdrawalEffect
+Maintainer : seungheon.ooh@gmail.com
+Description: Sample based testing for Treasury Withdrawal Effect
+
+This module specs the Treasury Withdrawal Effect.
+-}
+module Spec.Effect.TreasuryWithdrawal (specs) where
+
+import Agora.Effect.TreasuryWithdrawal (
+  TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
+  treasuryWithdrawalValidator,
+ )
+import Plutus.V1.Ledger.Value qualified as Value
+import Sample.Effect.TreasuryWithdrawal (
+  buildReceiversOutputFromDatum,
+  buildScriptContext,
+  currSymbol,
+  inputCollateral,
+  inputGAT,
+  inputTreasury,
+  inputUser,
+  outputTreasury,
+  outputUser,
+  treasuries,
+  users,
+ )
+import Test.Specification (
+  SpecificationTree,
+  effectFailsWith,
+  effectSucceedsWith,
+  group,
+ )
+
+specs :: [SpecificationTree]
+specs =
+  [ group
+      "effect"
+      [ effectSucceedsWith
+          "Simple"
+          (treasuryWithdrawalValidator currSymbol)
+          datum1
+          ( buildScriptContext
+              [ inputGAT
+              , inputCollateral 10
+              , inputTreasury 1 (asset1 10)
+              ]
+              $ outputTreasury 1 (asset1 7) :
+              buildReceiversOutputFromDatum datum1
+          )
+      , effectSucceedsWith
+          "Simple with multiple treasuries "
+          (treasuryWithdrawalValidator currSymbol)
+          datum1
+          ( buildScriptContext
+              [ inputGAT
+              , inputCollateral 10
+              , inputTreasury 1 (asset1 10)
+              , inputTreasury 2 (asset1 100)
+              , inputTreasury 3 (asset1 500)
+              ]
+              $ [ outputTreasury 1 (asset1 7)
+                , outputTreasury 2 (asset1 100)
+                , outputTreasury 3 (asset1 500)
+                ]
+                ++ buildReceiversOutputFromDatum datum1
+          )
+      , effectSucceedsWith
+          "Mixed Assets"
+          (treasuryWithdrawalValidator currSymbol)
+          datum2
+          ( buildScriptContext
+              [ inputGAT
+              , inputCollateral 10
+              , inputTreasury 1 (asset1 20)
+              , inputTreasury 2 (asset2 20)
+              ]
+              $ [ outputTreasury 1 (asset1 13)
+                , outputTreasury 2 (asset2 14)
+                ]
+                ++ buildReceiversOutputFromDatum datum2
+          )
+      , effectFailsWith
+          "Pay to uknown 3rd party"
+          (treasuryWithdrawalValidator currSymbol)
+          datum2
+          ( buildScriptContext
+              [ inputGAT
+              , inputCollateral 10
+              , inputTreasury 1 (asset1 20)
+              , inputTreasury 2 (asset2 20)
+              ]
+              $ [ outputUser 100 (asset1 2)
+                , outputTreasury 1 (asset1 11)
+                , outputTreasury 2 (asset2 14)
+                ]
+                ++ buildReceiversOutputFromDatum datum2
+          )
+      , effectFailsWith
+          "Missing receiver"
+          (treasuryWithdrawalValidator currSymbol)
+          datum2
+          ( buildScriptContext
+              [ inputGAT
+              , inputCollateral 10
+              , inputTreasury 1 (asset1 20)
+              , inputTreasury 2 (asset2 20)
+              ]
+              $ [ outputTreasury 1 (asset1 13)
+                , outputTreasury 2 (asset2 14)
+                ]
+                ++ drop 1 (buildReceiversOutputFromDatum datum2)
+          )
+      , effectFailsWith
+          "Unauthorized treasury"
+          (treasuryWithdrawalValidator currSymbol)
+          datum3
+          ( buildScriptContext
+              [ inputGAT
+              , inputCollateral 10
+              , inputTreasury 999 (asset1 20)
+              ]
+              $ outputTreasury 999 (asset1 17) :
+              buildReceiversOutputFromDatum datum3
+          )
+      , effectFailsWith
+          "Prevent transactions besides the withdrawal"
+          (treasuryWithdrawalValidator currSymbol)
+          datum3
+          ( buildScriptContext
+              [ inputGAT
+              , inputTreasury 1 (asset1 20)
+              , inputTreasury 999 (asset1 20)
+              , inputUser 99 (asset2 100)
+              ]
+              $ [ outputTreasury 1 (asset1 17)
+                , outputUser 100 (asset2 100)
+                ]
+                ++ buildReceiversOutputFromDatum datum3
+          )
+      ]
+  ]
+  where
+    asset1 = Value.singleton "abbc12" "OrangeBottle"
+    asset2 = Value.singleton "abbc12" "19721121"
+    datum1 =
+      TreasuryWithdrawalDatum
+        [ (head users, asset1 1)
+        , (users !! 1, asset1 1)
+        , (users !! 2, asset1 1)
+        ]
+        [ treasuries !! 1
+        , treasuries !! 2
+        , treasuries !! 3
+        ]
+    datum2 =
+      TreasuryWithdrawalDatum
+        [ (head users, asset1 4 <> asset2 5)
+        , (users !! 1, asset1 2 <> asset2 1)
+        , (users !! 2, asset1 1)
+        ]
+        [ head treasuries
+        , treasuries !! 1
+        , treasuries !! 2
+        ]
+    datum3 =
+      TreasuryWithdrawalDatum
+        [ (head users, asset1 1)
+        , (users !! 1, asset1 1)
+        , (users !! 2, asset1 1)
+        ]
+        [treasuries !! 1]

agora-specs/Spec/Governor.hs

@@ -0,0 +1,77 @@
+{- |
+Module     : Spec.Governor
+Maintainer : connor@mlabs.city
+Description: Tests for Agora governor.
+
+Thie module exports `specs`, a list of `TestTree`s, which ensure
+that Agora's governor component workds as intended.
+
+Tests should pass when the validator or policy is given one of the
+valid script contexts, which are defined in 'Agora.Sample.Governor'.
+
+TODO: Add negative test cases, see [#76](https://github.com/Liqwid-Labs/agora/issues/76).
+-}
+module Spec.Governor (specs) where
+
+import Agora.Governor (GovernorDatum (..), GovernorRedeemer (..))
+import Agora.Governor.Scripts (governorPolicy, governorValidator)
+import Agora.Proposal (ProposalId (..))
+import Data.Default.Class (Default (def))
+import Sample.Governor (createProposal, mintGATs, mintGST, mutateState)
+import Sample.Shared qualified as Shared
+import Test.Specification (
+  SpecificationTree,
+  group,
+  policySucceedsWith,
+  validatorSucceedsWith,
+ )
+
+--------------------------------------------------------------------------------
+
+specs :: [SpecificationTree]
+specs =
+  [ group
+      "policy"
+      [ policySucceedsWith
+          "GST minting"
+          (governorPolicy Shared.governor)
+          ()
+          mintGST
+      ]
+  , group
+      "validator"
+      [ validatorSucceedsWith
+          "proposal creation"
+          (governorValidator Shared.governor)
+          ( GovernorDatum
+              def
+              (ProposalId 0)
+              def
+              def
+          )
+          CreateProposal
+          createProposal
+      , validatorSucceedsWith
+          "GATs minting"
+          (governorValidator Shared.governor)
+          ( GovernorDatum
+              def
+              (ProposalId 5)
+              def
+              def
+          )
+          MintGATs
+          mintGATs
+      , validatorSucceedsWith
+          "mutate governor state"
+          (governorValidator Shared.governor)
+          ( GovernorDatum
+              def
+              (ProposalId 5)
+              def
+              def
+          )
+          MutateGovernor
+          mutateState
+      ]
+  ]

agora-specs/Spec/Model/MultiSig.hs

@@ -0,0 +1,194 @@
+{- |
+Module     : Spec.Model.MultiSig
+Maintainer : emi@haskell.fyi
+Description: apropos-tx model and tests for 'MultiSig' functions
+
+apropos-tx model and tests for 'MultiSig' functions
+-}
+module Spec.Model.MultiSig (
+  plutarchTests,
+  genTests,
+) where
+
+import Data.List (intersect)
+
+--------------------------------------------------------------------------------
+
+import Plutus.V1.Ledger.Api (
+  Script,
+  ScriptContext (scriptContextPurpose),
+  ScriptPurpose (Spending),
+  TxInfo (
+    txInfoDCert,
+    txInfoData,
+    txInfoFee,
+    txInfoId,
+    txInfoInputs,
+    txInfoMint,
+    txInfoOutputs,
+    txInfoValidRange,
+    txInfoWdrl
+  ),
+  TxOutRef (TxOutRef),
+  scriptContextTxInfo,
+  txInfoSignatories,
+ )
+import Plutus.V1.Ledger.Contexts (ScriptContext (ScriptContext), TxInfo (TxInfo))
+import Plutus.V1.Ledger.Crypto (PubKeyHash)
+import Plutus.V1.Ledger.Interval qualified as Interval
+import Plutus.V1.Ledger.Value qualified as Value
+
+--------------------------------------------------------------------------------
+
+import Apropos (
+  Apropos (Apropos),
+  Formula (ExactlyOne, Var, Yes),
+  HasLogicalModel (..),
+  HasParameterisedGenerator,
+  LogicalModel (logic),
+  parameterisedGenerator,
+  runGeneratorTestsWhere,
+  (:+),
+ )
+import Apropos.Gen (Gen, choice, int, linear, list)
+import Apropos.LogicalModel (Enumerable)
+import Apropos.LogicalModel.Enumerable (Enumerable (enumerated))
+import Apropos.Script (ScriptModel (expect, runScriptTestsWhere, script))
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.Hedgehog (fromGroup)
+
+--------------------------------------------------------------------------------
+
+import Agora.MultiSig (MultiSig (..), validatedByMultisig)
+
+--------------------------------------------------------------------------------
+
+-- | apropos model for testing multisigs.
+data MultiSigModel = MultiSigModel
+  { ms :: MultiSig
+  -- ^ `MultiSig` value to be tested.
+  , ctx :: ScriptContext
+  -- ^ The `ScriptContext` of the transaction.
+  }
+  deriving stock (Eq, Show)
+
+-- | Propositions that may hold true of a `MultiSigModel`.
+data MultiSigProp
+  = -- | Sufficient number of signatories in the script context.
+    MeetsMinSigs
+  | -- | Insufficient number of signatories in the script context.
+    DoesNotMeetMinSigs
+  deriving stock (Eq, Show, Ord)
+
+instance Enumerable MultiSigProp where
+  enumerated = [MeetsMinSigs, DoesNotMeetMinSigs]
+
+instance LogicalModel MultiSigProp where
+  -- Only logical relationship between the two propositions is
+  -- that exactly one of them holds for a given model.
+  logic = ExactlyOne [Var MeetsMinSigs, Var DoesNotMeetMinSigs]
+
+instance HasLogicalModel MultiSigProp MultiSigModel where
+  satisfiesProperty :: MultiSigProp -> MultiSigModel -> Bool
+  satisfiesProperty p m =
+    let minSigs = m.ms.minSigs
+        signatories = txInfoSignatories $ scriptContextTxInfo $ m.ctx
+        matchingSigs = intersect m.ms.keys signatories
+     in case p of
+          MeetsMinSigs -> length matchingSigs >= fromInteger minSigs
+          DoesNotMeetMinSigs -> length matchingSigs < fromInteger minSigs
+
+{- | Given a list of key hashes, returns a dummy `ScriptContext`,
+     with those hashes as signatories.
+-}
+contextWithSignatures :: [PubKeyHash] -> ScriptContext
+contextWithSignatures sigs =
+  ScriptContext
+    { scriptContextTxInfo =
+        TxInfo
+          { txInfoInputs = []
+          , txInfoOutputs = []
+          , txInfoFee = Value.singleton "" "" 2
+          , txInfoMint = mempty
+          , txInfoDCert = []
+          , txInfoWdrl = []
+          , txInfoValidRange = Interval.always
+          , txInfoSignatories = sigs
+          , txInfoData = []
+          , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
+          }
+    , scriptContextPurpose = Spending (TxOutRef "" 0)
+    }
+
+-- | Generator returning one of four dummy public key hashes.
+genPK :: Gen PubKeyHash
+genPK =
+  choice
+    [ pure "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
+    , pure "0b12051dd2da4b3629cebb92e2be111e0e99c63c04727ed55b74a296"
+    , pure "87f5f31e4d7437463cd901c4c9edb7a51903ac858661503e9d72f492"
+    , pure "f74ccaee8244264b3c73fce3b66bd2337de3db70efff4261d6ff145b"
+    ]
+
+instance HasParameterisedGenerator MultiSigProp MultiSigModel where
+  parameterisedGenerator s = do
+    -- Gen between one and four signatures for the `MultiSig`.
+    expectedSignatures <- list (linear 1 4) genPK
+
+    -- Gen the value of `MultiSig.minSigs`.
+    minSigs <- toInteger <$> int (linear 1 (length expectedSignatures))
+
+    -- Assign values to msig.
+    let msig = MultiSig expectedSignatures minSigs
+
+    actualSignaturesLength <-
+      -- If we would like to generate a MultiSig model which passes...
+      if MeetsMinSigs `elem` s
+        then -- ... have a sufficient number of signatories.
+          int (linear (fromInteger minSigs) (length expectedSignatures))
+        else -- ... have zero signatories.
+          pure 0
+
+    -- Get a list of signatories for the script context.
+    let actualSignatures = take actualSignaturesLength expectedSignatures
+
+    let ctx = contextWithSignatures actualSignatures
+
+    -- Return the generated model.
+    pure (MultiSigModel msig ctx)
+
+instance ScriptModel MultiSigProp MultiSigModel where
+  -- When the script runs, we want the model to meet the minimum signatures.
+  expect :: (MultiSigModel :+ MultiSigProp) -> Formula MultiSigProp
+  expect Apropos = Var MeetsMinSigs
+
+  -- Function making a valid script from the model and propositions.
+  script :: (MultiSigModel :+ MultiSigProp) -> MultiSigModel -> Script
+  script Apropos msm =
+    compile $
+      pif
+        (validatedByMultisig msm.ms # pconstant msm.ctx.scriptContextTxInfo)
+        (pcon PUnit)
+        perror
+
+-- | Consistency tests for the 'HasParameterisedGenerator' instance of 'MultiSigModel'.
+genTests :: TestTree
+genTests =
+  testGroup "genTests" $
+    fromGroup
+      <$> [ runGeneratorTestsWhere
+              (Apropos :: MultiSigModel :+ MultiSigProp)
+              "Generator"
+              Yes
+          ]
+
+-- | Tests for the 'ScriptModel' instance of 'MultiSigModel'.
+plutarchTests :: TestTree
+plutarchTests =
+  testGroup "plutarchTests" $
+    fromGroup
+      <$> [ runScriptTestsWhere
+              (Apropos :: MultiSigModel :+ MultiSigProp)
+              "ScriptValid"
+              Yes
+          ]

agora-specs/Spec/Proposal.hs

@@ -0,0 +1,348 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+{- |
+Module     : Spec.Proposal
+Maintainer : emi@haskell.fyi
+Description: Tests for Proposal policy and validator
+
+Tests for Proposal policy and validator
+-}
+module Spec.Proposal (specs) where
+
+--------------------------------------------------------------------------------
+
+import Agora.Proposal (
+  Proposal (..),
+  ProposalDatum (..),
+  ProposalId (ProposalId),
+  ProposalRedeemer (..),
+  ProposalStatus (..),
+  ProposalThresholds (..),
+  ProposalVotes (ProposalVotes),
+  ResultTag (ResultTag),
+  cosigners,
+  effects,
+  emptyVotesFor,
+  proposalId,
+  status,
+  thresholds,
+  votes,
+ )
+import Agora.Proposal.Scripts (
+  proposalPolicy,
+  proposalValidator,
+ )
+import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime))
+import Agora.Stake (
+  ProposalLock (ProposalLock),
+  StakeDatum (StakeDatum),
+  StakeRedeemer (PermitVote, WitnessStake),
+ )
+import Agora.Stake.Scripts (stakeValidator)
+import Data.Default.Class (Default (def))
+import Data.Tagged (Tagged (Tagged), untag)
+import Plutus.V1.Ledger.Api (ScriptContext (..), ScriptPurpose (..))
+import PlutusTx.AssocMap qualified as AssocMap
+import Sample.Proposal qualified as Proposal
+import Sample.Shared (signer, signer2)
+import Sample.Shared qualified as Shared
+import Test.Specification (
+  SpecificationTree,
+  group,
+  policySucceedsWith,
+  validatorFailsWith,
+  validatorSucceedsWith,
+ )
+
+--------------------------------------------------------------------------------
+
+-- | Stake specs.
+specs :: [SpecificationTree]
+specs =
+  [ group
+      "policy"
+      [ policySucceedsWith
+          "proposalCreation"
+          (proposalPolicy Shared.proposal.governorSTAssetClass)
+          ()
+          Proposal.proposalCreation
+      ]
+  , group
+      "validator"
+      [ group
+          "cosignature"
+          [ validatorSucceedsWith
+              "proposal"
+              (proposalValidator Shared.proposal)
+              ( ProposalDatum
+                  { proposalId = ProposalId 0
+                  , effects =
+                      AssocMap.fromList
+                        [ (ResultTag 0, AssocMap.empty)
+                        , (ResultTag 1, AssocMap.empty)
+                        ]
+                  , status = Draft
+                  , cosigners = [signer]
+                  , thresholds = def
+                  , votes =
+                      emptyVotesFor $
+                        AssocMap.fromList
+                          [ (ResultTag 0, AssocMap.empty)
+                          , (ResultTag 1, AssocMap.empty)
+                          ]
+                  , timingConfig = def
+                  , startingTime = ProposalStartingTime 0
+                  }
+              )
+              (Cosign [signer2])
+              (ScriptContext (Proposal.cosignProposal [signer2]) (Spending Proposal.proposalRef))
+          , validatorSucceedsWith
+              "stake"
+              (stakeValidator Shared.stake)
+              (StakeDatum (Tagged 50_000_000) signer2 [])
+              WitnessStake
+              (ScriptContext (Proposal.cosignProposal [signer2]) (Spending Proposal.stakeRef))
+          ]
+      , group
+          "voting"
+          [ validatorSucceedsWith
+              "proposal"
+              (proposalValidator Shared.proposal)
+              ( ProposalDatum
+                  { proposalId = ProposalId 42
+                  , effects =
+                      AssocMap.fromList
+                        [ (ResultTag 0, AssocMap.empty)
+                        , (ResultTag 1, AssocMap.empty)
+                        ]
+                  , status = VotingReady
+                  , cosigners = [signer]
+                  , thresholds = def
+                  , votes =
+                      ProposalVotes
+                        ( AssocMap.fromList
+                            [ (ResultTag 0, 42)
+                            , (ResultTag 1, 4242)
+                            ]
+                        )
+                  , timingConfig = def
+                  , startingTime = ProposalStartingTime 0
+                  }
+              )
+              (Vote (ResultTag 0))
+              ( ScriptContext
+                  ( Proposal.voteOnProposal
+                      Proposal.VotingParameters
+                        { Proposal.voteFor = ResultTag 0
+                        , Proposal.voteCount = 27
+                        }
+                  )
+                  (Spending Proposal.proposalRef)
+              )
+          , validatorSucceedsWith
+              "stake"
+              (stakeValidator Shared.stake)
+              ( StakeDatum
+                  (Tagged 27)
+                  signer
+                  [ ProposalLock (ResultTag 0) (ProposalId 0)
+                  , ProposalLock (ResultTag 2) (ProposalId 1)
+                  ]
+              )
+              (PermitVote $ ProposalLock (ResultTag 0) (ProposalId 42))
+              ( ScriptContext
+                  ( Proposal.voteOnProposal
+                      Proposal.VotingParameters
+                        { Proposal.voteFor = ResultTag 0
+                        , Proposal.voteCount = 27
+                        }
+                  )
+                  (Spending Proposal.stakeRef)
+              )
+          ]
+      , group
+          "advancing"
+          [ group "successfully advance to next state" $
+              map
+                ( \(name, initialState) ->
+                    validatorSucceedsWith
+                      name
+                      (proposalValidator Shared.proposal)
+                      ( ProposalDatum
+                          { proposalId = ProposalId 0
+                          , effects =
+                              AssocMap.fromList
+                                [ (ResultTag 0, AssocMap.empty)
+                                , (ResultTag 1, AssocMap.empty)
+                                ]
+                          , status = initialState
+                          , cosigners = [signer]
+                          , thresholds = def
+                          , votes =
+                              ProposalVotes
+                                ( AssocMap.fromList
+                                    [
+                                      ( ResultTag 0
+                                      , case initialState of
+                                        Draft -> 0
+                                        _ -> untag (def :: ProposalThresholds).countVoting + 1
+                                      )
+                                    , (ResultTag 1, 0)
+                                    ]
+                                )
+                          , timingConfig = def
+                          , startingTime = ProposalStartingTime 0
+                          }
+                      )
+                      AdvanceProposal
+                      ( ScriptContext
+                          ( Proposal.advanceProposalSuccess
+                              Proposal.TransitionParameters
+                                { Proposal.initialProposalStatus = initialState
+                                , Proposal.proposalStartingTime = ProposalStartingTime 0
+                                }
+                          )
+                          (Spending Proposal.proposalRef)
+                      )
+                )
+                [ ("Draft -> VotringReady", Draft)
+                , ("VotingReady -> Locked", VotingReady)
+                , ("Locked -> Finished", Locked)
+                ]
+          , group "successfully advance to failed state: timeout" $
+              map
+                ( \(name, initialState) ->
+                    validatorSucceedsWith
+                      name
+                      (proposalValidator Shared.proposal)
+                      ( ProposalDatum
+                          { proposalId = ProposalId 0
+                          , effects =
+                              AssocMap.fromList
+                                [ (ResultTag 0, AssocMap.empty)
+                                , (ResultTag 1, AssocMap.empty)
+                                ]
+                          , status = initialState
+                          , cosigners = [signer]
+                          , thresholds = def
+                          , votes =
+                              ProposalVotes
+                                ( AssocMap.fromList
+                                    [
+                                      ( ResultTag 0
+                                      , case initialState of
+                                        Draft -> 0
+                                        _ -> untag (def :: ProposalThresholds).countVoting + 1
+                                      )
+                                    , (ResultTag 1, 0)
+                                    ]
+                                )
+                          , timingConfig = def
+                          , startingTime = ProposalStartingTime 0
+                          }
+                      )
+                      AdvanceProposal
+                      ( ScriptContext
+                          ( Proposal.advanceProposalFailureTimeout
+                              Proposal.TransitionParameters
+                                { Proposal.initialProposalStatus = initialState
+                                , Proposal.proposalStartingTime = ProposalStartingTime 0
+                                }
+                          )
+                          (Spending Proposal.proposalRef)
+                      )
+                )
+                [ ("Draft -> Finished", Draft)
+                , ("VotingReady -> Finished", VotingReady)
+                , ("Locked -> Finished", Locked)
+                ]
+          , validatorFailsWith
+              "illegal: insufficient votes"
+              (proposalValidator Shared.proposal)
+              ( ProposalDatum
+                  { proposalId = ProposalId 0
+                  , effects =
+                      AssocMap.fromList
+                        [ (ResultTag 0, AssocMap.empty)
+                        , (ResultTag 1, AssocMap.empty)
+                        ]
+                  , status = VotingReady
+                  , cosigners = [signer]
+                  , thresholds = def
+                  , votes =
+                      ProposalVotes
+                        ( AssocMap.fromList
+                            [ (ResultTag 0, 0)
+                            , (ResultTag 1, 0)
+                            ]
+                        )
+                  , timingConfig = def
+                  , startingTime = ProposalStartingTime 0
+                  }
+              )
+              AdvanceProposal
+              ( ScriptContext
+                  Proposal.advanceProposalInsufficientVotes
+                  (Spending Proposal.proposalRef)
+              )
+          , validatorFailsWith
+              "illegal: initial state is Finished"
+              (proposalValidator Shared.proposal)
+              ( ProposalDatum
+                  { proposalId = ProposalId 0
+                  , effects =
+                      AssocMap.fromList
+                        [ (ResultTag 0, AssocMap.empty)
+                        , (ResultTag 1, AssocMap.empty)
+                        ]
+                  , status = Finished
+                  , cosigners = [signer]
+                  , thresholds = def
+                  , votes =
+                      ProposalVotes
+                        ( AssocMap.fromList
+                            [ (ResultTag 0, untag (def :: ProposalThresholds).countVoting + 1)
+                            , (ResultTag 1, 0)
+                            ]
+                        )
+                  , timingConfig = def
+                  , startingTime = ProposalStartingTime 0
+                  }
+              )
+              AdvanceProposal
+              ( ScriptContext
+                  Proposal.advanceFinishedPropsoal
+                  (Spending Proposal.proposalRef)
+              )
+          , validatorFailsWith
+              "illegal: with stake input"
+              (proposalValidator Shared.proposal)
+              ( ProposalDatum
+                  { proposalId = ProposalId 0
+                  , effects =
+                      AssocMap.fromList
+                        [ (ResultTag 0, AssocMap.empty)
+                        , (ResultTag 1, AssocMap.empty)
+                        ]
+                  , status = VotingReady
+                  , cosigners = [signer]
+                  , thresholds = def
+                  , votes =
+                      ProposalVotes
+                        ( AssocMap.fromList
+                            [ (ResultTag 0, 0)
+                            , (ResultTag 1, 0)
+                            ]
+                        )
+                  , timingConfig = def
+                  , startingTime = ProposalStartingTime 0
+                  }
+              )
+              AdvanceProposal
+              ( ScriptContext
+                  Proposal.advancePropsoalWithsStake
+                  (Spending Proposal.proposalRef)
+              )
+          ]
+      ]
+  ]

agora-specs/Spec/Stake.hs

@@ -0,0 +1,78 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+{- |
+Module     : Spec.Stake
+Maintainer : emi@haskell.fyi
+Description: Tests for Stake policy and validator
+
+Tests for Stake policy and validator
+-}
+module Spec.Stake (specs) where
+
+--------------------------------------------------------------------------------
+
+import Prelude
+
+--------------------------------------------------------------------------------
+
+import Agora.Stake (Stake (..), StakeDatum (StakeDatum), StakeRedeemer (DepositWithdraw))
+import Agora.Stake.Scripts (stakePolicy, stakeValidator)
+
+--------------------------------------------------------------------------------
+
+import Sample.Stake (DepositWithdrawExample (DepositWithdrawExample, delta, startAmount), signer)
+import Sample.Stake qualified as Stake
+import Test.Specification (
+  SpecificationTree,
+  group,
+  policyFailsWith,
+  policySucceedsWith,
+  validatorFailsWith,
+  validatorSucceedsWith,
+ )
+import Test.Util (toDatum)
+
+--------------------------------------------------------------------------------
+
+specs :: [SpecificationTree]
+specs =
+  [ group
+      "policy"
+      [ policySucceedsWith
+          "stakeCreation"
+          (stakePolicy Stake.stake.gtClassRef)
+          ()
+          Stake.stakeCreation
+      , policyFailsWith
+          "stakeCreationWrongDatum"
+          (stakePolicy Stake.stake.gtClassRef)
+          ()
+          Stake.stakeCreationWrongDatum
+      , policyFailsWith
+          "stakeCreationUnsigned"
+          (stakePolicy Stake.stake.gtClassRef)
+          ()
+          Stake.stakeCreationUnsigned
+      ]
+  , group
+      "validator"
+      [ validatorSucceedsWith
+          "stakeDepositWithdraw deposit"
+          (stakeValidator Stake.stake)
+          (toDatum $ StakeDatum 100_000 signer [])
+          (toDatum $ DepositWithdraw 100_000)
+          (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = 100_000})
+      , validatorSucceedsWith
+          "stakeDepositWithdraw withdraw"
+          (stakeValidator Stake.stake)
+          (toDatum $ StakeDatum 100_000 signer [])
+          (toDatum $ DepositWithdraw $ negate 100_000)
+          (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 100_000})
+      , validatorFailsWith
+          "stakeDepositWithdraw negative GT"
+          (stakeValidator Stake.stake)
+          (toDatum $ StakeDatum 100_000 signer [])
+          (toDatum $ DepositWithdraw 1_000_000)
+          (Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 1_000_000})
+      ]
+  ]

agora-specs/Spec/Treasury.hs

@@ -0,0 +1,146 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+{- |
+Module: Spec.Treasury
+Description: Tests for Agora treasury.
+Maintainer: jack@mlabs.city
+
+This module exports `specs`, a list of `TestTree`s, which ensure
+that Agora's treasury component works as desired.
+
+Tests need to fail when:
+
+  1. The reedeemer is of inproper form. TODO: Inquire.
+  2. The script purpose is not minting.
+  3. `singleAuthorityTokenBurned` returns false.
+    a. @n /= -1@ GATs burned.
+    b. An input returns 'False' for 'authorityTokensValidIn'
+      i. A wallet input has a GAT.
+      ii. A script has a GAT, the token name for which does /not/
+          match the script's validator hash.
+-}
+module Spec.Treasury (specs) where
+
+import Agora.Treasury (
+  TreasuryRedeemer (SpendTreasuryGAT),
+  treasuryValidator,
+ )
+import Plutus.V1.Ledger.Api (
+  DCert (DCertDelegRegKey),
+ )
+import Plutus.V1.Ledger.Contexts (
+  ScriptContext (scriptContextPurpose, scriptContextTxInfo),
+  ScriptPurpose (Certifying, Rewarding, Spending),
+  TxInfo (txInfoInputs, txInfoMint),
+ )
+import Plutus.V1.Ledger.Credential (
+  StakingCredential (StakingHash),
+ )
+import Plutus.V1.Ledger.Value qualified as Value
+import Sample.Shared (
+  trCredential,
+ )
+import Sample.Treasury (
+  gatCs,
+  gatTn,
+  trCtxGATNameNotAddress,
+  treasuryRef,
+  validCtx,
+  walletIn,
+ )
+import Test.Specification (
+  SpecificationTree,
+  group,
+  validatorFailsWith,
+  validatorSucceedsWith,
+ )
+
+specs :: [SpecificationTree]
+specs =
+  [ group
+      "Validator"
+      [ group
+          "Positive"
+          [ validatorSucceedsWith
+              "Allows for effect changes"
+              (treasuryValidator gatCs)
+              ()
+              SpendTreasuryGAT
+              validCtx
+          ]
+      , group
+          "Negative"
+          [ group
+              "Fails with ScriptPurpose not Minting"
+              [ validatorFailsWith
+                  "Spending"
+                  (treasuryValidator gatCs)
+                  ()
+                  SpendTreasuryGAT
+                  validCtx
+                    { scriptContextPurpose = Spending treasuryRef
+                    }
+              , validatorFailsWith
+                  "Rewarding"
+                  (treasuryValidator gatCs)
+                  ()
+                  SpendTreasuryGAT
+                  validCtx
+                    { scriptContextPurpose =
+                        Rewarding $
+                          StakingHash trCredential
+                    }
+              , validatorFailsWith
+                  "Certifying"
+                  (treasuryValidator gatCs)
+                  ()
+                  SpendTreasuryGAT
+                  validCtx
+                    { scriptContextPurpose =
+                        Certifying $
+                          DCertDelegRegKey $
+                            StakingHash trCredential
+                    }
+              ]
+          , validatorFailsWith -- TODO: Use QuickCheck.
+              "Fails when multiple GATs burned"
+              (treasuryValidator gatCs)
+              ()
+              SpendTreasuryGAT
+              validCtx
+                { scriptContextTxInfo =
+                    validCtx.scriptContextTxInfo
+                      { txInfoMint =
+                          Value.singleton
+                            gatCs
+                            gatTn
+                            (-2)
+                      }
+                }
+          , validatorFailsWith
+              "Fails when GAT token name is not script address"
+              (treasuryValidator gatCs)
+              ()
+              SpendTreasuryGAT
+              trCtxGATNameNotAddress
+          , validatorFailsWith
+              "Fails with wallet as input"
+              (treasuryValidator gatCs)
+              ()
+              SpendTreasuryGAT
+              ( let txInfo = validCtx.scriptContextTxInfo
+                    inputs = txInfo.txInfoInputs
+                    newInputs =
+                      [ head inputs
+                      , walletIn
+                      ]
+                 in validCtx
+                      { scriptContextTxInfo =
+                          txInfo
+                            { txInfoInputs = newInputs
+                            }
+                      }
+              )
+          ]
+      ]
+  ]

agora-specs/Spec/Utils.hs

@@ -0,0 +1,226 @@
+{- |
+Module     : Spec.Utils
+Maintainer : emi@haskell.fyi
+Description: Tests for utility functions in 'Agora.Utils'.
+
+Tests for utility functions in 'Agora.Utils'.
+-}
+module Spec.Utils (tests) where
+
+--------------------------------------------------------------------------------
+
+import Agora.Utils (phalve, pisUniq, pmergeBy, pmsort, pnubSort, pupdate)
+
+--------------------------------------------------------------------------------
+
+import Data.List (nub, sort)
+import Data.Map qualified as M
+import Data.Set qualified as S
+
+--------------------------------------------------------------------------------
+
+import Control.Monad.Cont (cont, runCont)
+import Test.Tasty (TestTree)
+import Test.Tasty.QuickCheck (
+  Arbitrary (arbitrary),
+  Property,
+  Testable (property),
+  elements,
+  forAll,
+  suchThat,
+  testProperty,
+  (.&&.),
+ )
+import Test.Util (updateMap)
+
+--------------------------------------------------------------------------------
+
+import PlutusTx.AssocMap qualified as AssocMap
+
+--------------------------------------------------------------------------------
+
+tests :: [TestTree]
+tests =
+  [ testProperty "'pmsort' sorts a list properly" prop_msortCorrect
+  , testProperty "'pmerge' merges two sorted lists into one sorted list" prop_mergeCorrect
+  , testProperty "'phalve' splits a list in half as expected" prop_halveCorrect
+  , testProperty "'pnubSort' sorts a list and remove duplicate elements" prop_nubSortProperly
+  , testProperty "'pisUniq' can tell whether all elements in a list are unique" prop_uniqueList
+  , testProperty "'pupdate' updates assoc maps as 'updateMap' does" prop_updateAssocMapParity
+  ]
+
+--------------------------------------------------------------------------------
+
+-- | Yield true if 'Agora.Utils.pmsort' sorts a given list correctly.
+prop_msortCorrect :: [Integer] -> Bool
+prop_msortCorrect l = sorted == expected
+  where
+    -- Expected sorted list, using 'Data.List.sort'.
+    expected :: [Integer]
+    expected = sort l
+
+    --
+
+    psorted :: Term _ (PBuiltinList PInteger)
+    psorted = pmsort # pconstant l
+
+    sorted :: [Integer]
+    sorted = plift psorted
+
+-- | Yield true if 'Agora.Utils.pmerge' merges two list into a ordered list correctly.
+prop_mergeCorrect :: [Integer] -> [Integer] -> Bool
+prop_mergeCorrect a b = merged == expected
+  where
+    -- Sorted list a and b
+    sa = sort a
+    sb = sort b
+
+    -- Merge two lists which are assumed to be ordered.
+    merge :: [Integer] -> [Integer] -> [Integer]
+    merge xs [] = xs
+    merge [] ys = ys
+    merge sx@(x : xs) sy@(y : ys)
+      | x <= y = x : merge xs sy
+      | otherwise = y : merge sx ys
+
+    expected :: [Integer]
+    expected = merge sa sb
+
+    --
+
+    pmerged :: Term _ (PBuiltinList PInteger)
+    pmerged = pmergeBy # plam (#<) # pconstant sa # pconstant sb
+
+    merged :: [Integer]
+    merged = plift pmerged
+
+{- | Yield true if Plutarch level 'Agora.Utils.phalve' splits a given list
+   as its Haskell level counterpart does.
+-}
+prop_halveCorrect :: [Integer] -> Bool
+prop_halveCorrect l = halved == expected
+  where
+    -- Halve a list.
+    halve :: [Integer] -> ([Integer], [Integer])
+    halve xs = go xs xs
+      where
+        go xs [] = ([], xs)
+        go (x : xs) [_] = ([x], xs)
+        go (x : xs) (_ : _ : ys) =
+          let (first, last) =
+                go xs ys
+           in (x : first, last)
+        go [] _ = ([], [])
+
+    expected :: ([Integer], [Integer])
+    expected = halve l
+
+    --
+
+    phalved :: Term _ (PPair (PBuiltinList PInteger) (PBuiltinList PInteger))
+    phalved = phalve # pconstant l
+
+    halved :: ([Integer], [Integer])
+    halved =
+      let f = plift $ pmatch phalved $ \(PPair x _) -> x
+          s = plift $ pmatch phalved $ \(PPair _ x) -> x
+       in (f, s)
+
+{- | Yield true if 'Agora.Utils.pnubSort' sorts and removes
+   duplicate elements from a given list.
+-}
+prop_nubSortProperly :: [Integer] -> Bool
+prop_nubSortProperly l = nubbed == expected
+  where
+    -- Sort and list and then nub it.
+    expected :: [Integer]
+    expected = nub $ sort l
+
+    --
+
+    pnubbed :: Term _ (PBuiltinList PInteger)
+    pnubbed = pnubSort # pconstant l
+
+    nubbed :: [Integer]
+    nubbed = plift pnubbed
+
+{- | Yield true if 'Agora.Utils.isUnique' can correctly determine
+   whether a given list only contains unique elements or not.
+-}
+prop_uniqueList :: [Integer] -> Bool
+prop_uniqueList l = isUnique == expected
+  where
+    -- Convert input list to a set.
+    -- If the set's size equals to list's size,
+    --   the list only contains unique elements.
+    expected :: Bool
+    expected = S.size (S.fromList l) == length l
+
+    --
+
+    isUnique = plift $ pisUniq # pconstant l
+
+{- | Test the parity between 'updateMap' and 'pupdate',
+     also ensure they both work correctly.
+-}
+prop_updateAssocMapParity :: Property
+prop_updateAssocMapParity =
+  runCont
+    ( do
+        -- Generate a bunch unique keys.
+        keys <-
+          cont $
+            forAll $
+              arbitrary @(S.Set Integer) `suchThat` (not . S.null)
+
+        -- Generate key-value pairs.
+        kvPairs <- cont $ forAll $ mapM (\k -> (k,) <$> (arbitrary @Integer)) $ S.toList keys
+
+        let initialMap = AssocMap.fromList kvPairs
+
+            pinitialMap :: Term _ _
+            pinitialMap = phoistAcyclic $ pconstant initialMap
+
+            referenceMap = M.fromList kvPairs
+
+        let pupdatedValue :: Maybe Integer -> Term _ (PMaybe PInteger)
+            pupdatedValue updatedValue = phoistAcyclic $ case updatedValue of
+              Nothing -> pcon PNothing
+              Just v -> pcon $ PJust $ pconstant v
+
+            -- Given the key and the updated value, test the parity
+            parity key updatedValue =
+              let native = updateMap (const updatedValue) key initialMap
+
+                  plutarch :: AssocMap.Map Integer Integer
+                  plutarch =
+                    plift $
+                      pupdate
+                        # plam (\_ -> pupdatedValue updatedValue)
+                        # pconstant key
+                        # pinitialMap
+
+                  expected =
+                    AssocMap.fromList $
+                      M.toList $
+                        M.update (const updatedValue) key referenceMap
+               in expected == native
+                    && expected == plutarch
+
+        -- Select a key, generate a maybe value.
+        -- The value at the key should be set to the new value or removed.
+        (targetKey, _) <- cont $ forAll $ elements kvPairs
+        updatedValue <- cont $ forAll $ arbitrary @(Maybe Integer)
+
+        -- Now what if the key doesn't exist in our map?
+        nonexistentKey <-
+          cont $
+            forAll $
+              arbitrary @Integer `suchThat` (\k -> not $ S.member k keys)
+
+        pure
+          ( property (parity targetKey updatedValue)
+              .&&. property (parity nonexistentKey updatedValue)
+          )
+    )
+    id