fix sample tests for unlocking stakes

agora-specs/Sample/Proposal/Unlock.hs

@@ -0,0 +1,541 @@
+{- |
+Module     : Sample.Proposal.UnlockStake
+Maintainer : connor@mlabs.city
+Description: Generate sample data for testing the functionalities of unlocking stake and retracting votes
+
+Sample and utilities for testing the functionalities of unlocking stake and retracting votes
+-}
+module Sample.Proposal.Unlock (
+  ParameterBundle (..),
+  StakeRole (..),
+  TimeRange (..),
+  SignedBy (..),
+  TransactionParameters (..),
+  ProposalParameters (..),
+  StakeParameters (..),
+  Validity (..),
+  unlock,
+  mkTestTree,
+  mkValidVoterRetractVotes,
+  mkValidDelegateeRetractVotes,
+  mkValidVoterCreatorRetractVotes,
+  mkValidCreatorRemoveLock,
+  mkValidVoterRemoveLockAfterVoting,
+  mkRetractVotesWhileNotVoting,
+  mkUnockIrrelevantStakes,
+  mkRemoveCreatorLockBeforeFinished,
+  mkCreatorRetractVotes,
+  mkChangeOutputStakeValue,
+) where
+
+--------------------------------------------------------------------------------
+
+import Agora.Governor (Governor (..))
+import Agora.Proposal (
+  ProposalDatum (..),
+  ProposalEffectGroup,
+  ProposalId (..),
+  ProposalRedeemer (Unlock),
+  ProposalStatus (..),
+  ProposalVotes (..),
+  ResultTag (..),
+ )
+import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime), ProposalTimingConfig (..))
+import Agora.Scripts (AgoraScripts (..))
+import Agora.Stake (
+  ProposalLock (..),
+  StakeDatum (..),
+  StakeRedeemer (RetractVotes),
+ )
+import Data.Default.Class (Default (def))
+import Data.Map.Strict qualified as StrictMap
+import Data.Tagged (Tagged (Tagged), untag)
+import Plutarch.Context (
+  input,
+  normalizeValue,
+  output,
+  script,
+  signedWith,
+  timeRange,
+  txId,
+  withDatum,
+  withRedeemer,
+  withRef,
+  withValue,
+ )
+import Plutarch.SafeMoney (Discrete (Discrete))
+import PlutusLedgerApi.V1.Value qualified as Value
+import PlutusLedgerApi.V2 (
+  Credential (PubKeyCredential),
+  PubKeyHash,
+  TxOutRef (..),
+ )
+import Sample.Proposal.Shared (stakeTxRef)
+import Sample.Shared (
+  agoraScripts,
+  governor,
+  minAda,
+  proposalPolicySymbol,
+  proposalValidatorHash,
+  stakeAssetClass,
+  stakeValidatorHash,
+ )
+import Test.Specification (SpecificationTree, group, testValidator)
+import Test.Util (CombinableBuilder, closedBoundedInterval, mkSpending, pubKeyHashes)
+
+--------------------------------------------------------------------------------
+
+votesTemplate :: ProposalVotes
+votesTemplate =
+  ProposalVotes $
+    StrictMap.fromList
+      [ (ResultTag 0, 0)
+      , (ResultTag 1, 0)
+      ]
+
+-- | Create empty effects for every result tag given the votes.
+emptyEffectFor ::
+  ProposalVotes ->
+  StrictMap.Map ResultTag ProposalEffectGroup
+emptyEffectFor (ProposalVotes vs) =
+  StrictMap.fromList $
+    map (,StrictMap.empty) (StrictMap.keys vs)
+
+-- | The default vote option that will be used by functions in this module.
+defVoteFor :: ResultTag
+defVoteFor = ResultTag 0
+
+-- | The default number of GTs the stake will have.
+defStakedGTs :: Integer
+defStakedGTs = 100000
+
+alteredStakedGTs :: Integer
+alteredStakedGTs = 100
+
+-- | Default owner of the stakes.
+defOwner :: PubKeyHash
+defOwner = pubKeyHashes !! 1
+
+defDelegatee :: PubKeyHash
+defDelegatee = pubKeyHashes !! 2
+
+defUnknown :: PubKeyHash
+defUnknown = pubKeyHashes !! 3
+
+defProposalId :: ProposalId
+defProposalId = ProposalId 0
+
+defStartingTime :: ProposalStartingTime
+defStartingTime = ProposalStartingTime 0
+
+--------------------------------------------------------------------------------
+
+data ParameterBundle = ParameterBundle
+  { proposalParameters :: ProposalParameters
+  , stakeParameters :: StakeParameters
+  , transactionParameters :: TransactionParameters
+  }
+
+data SignedBy = Owner | Delegatee | Unknown
+
+data TimeRange = WhileVoting | AfterVoting
+
+data TransactionParameters = TransactionParameters
+  { signedBy :: SignedBy
+  , timeRange :: TimeRange
+  }
+
+data ProposalParameters = ProposalParameters
+  { proposalStatus :: ProposalStatus
+  , retractVotes :: Bool
+  }
+
+-- | How a stake has been used on a particular proposal.
+data StakeRole
+  = -- | The stake was spent to vote for a paraticular option.
+    Voter
+  | -- | The stake was used to create the proposal.
+    Creator
+  | -- | The stake was used to both create and vote for the proposal.
+    Both
+  | -- | The stake has nothing to do with the proposal.
+    Irrelevant
+  deriving stock (Bounded, Enum, Show)
+
+data StakeParameters = StakeParameters
+  { numStakes :: Integer
+  , stakeRole :: StakeRole
+  , removeVoterLock :: Bool
+  , removeCreatorLock :: Bool
+  , alterOutputValue :: Bool
+  }
+
+data Validity = Validity
+  { forProposalValidator :: Bool
+  , forStakeValidator :: Bool
+  }
+
+--------------------------------------------------------------------------------
+
+mkStakeRef :: Integer -> TxOutRef
+mkStakeRef = TxOutRef stakeTxRef
+
+stakeRedeemer :: StakeRedeemer
+stakeRedeemer = RetractVotes
+
+mkStakeInputDatum :: StakeParameters -> StakeDatum
+mkStakeInputDatum ps =
+  StakeDatum
+    { stakedAmount = Discrete $ Tagged defStakedGTs
+    , owner = PubKeyCredential defOwner
+    , delegatedTo = Just $ PubKeyCredential defDelegatee
+    , lockedBy = stakeLocks
+    }
+  where
+    stakeLocks = mkStakeLocks' ps.stakeRole
+
+    mkStakeLocks' Voter = [Voted defProposalId defVoteFor]
+    mkStakeLocks' Creator = [Created defProposalId]
+    mkStakeLocks' Both = mkStakeLocks' Voter <> mkStakeLocks' Creator
+    mkStakeLocks' Irrelevant =
+      let ProposalId pid = defProposalId
+          ResultTag vid = defVoteFor
+       in [ Voted (ProposalId $ pid + 1) (ResultTag $ vid + 1)
+          , Created (ProposalId $ pid + 1)
+          ]
+
+--------------------------------------------------------------------------------
+
+proposalRef :: TxOutRef
+proposalRef = TxOutRef stakeTxRef 0
+
+proposalRedeemer :: ProposalRedeemer
+proposalRedeemer = Unlock
+
+mkProposalInputDatum ::
+  StakeParameters ->
+  ProposalParameters ->
+  ProposalDatum
+mkProposalInputDatum sps pps =
+  ProposalDatum
+    { proposalId = defProposalId
+    , effects = emptyEffectFor votesTemplate
+    , status = pps.proposalStatus
+    , cosigners = [PubKeyCredential $ head pubKeyHashes]
+    , thresholds = def
+    , votes = updatVotes votesTemplate
+    , timingConfig = def
+    , startingTime = defStartingTime
+    }
+  where
+    updatVotes (ProposalVotes vt) =
+      ProposalVotes $
+        StrictMap.adjust
+          (+ sps.numStakes * defStakedGTs)
+          defVoteFor
+          vt
+
+--------------------------------------------------------------------------------
+
+unlock :: forall b. CombinableBuilder b => ParameterBundle -> b
+unlock ps = builder
+  where
+    pst = Value.singleton proposalPolicySymbol "" 1
+
+    proposalInputDatum =
+      mkProposalInputDatum
+        ps.stakeParameters
+        ps.proposalParameters
+
+    proposalOutputDatum =
+      if ps.proposalParameters.retractVotes
+        then proposalInputDatum {votes = votesTemplate}
+        else proposalInputDatum
+
+    proposalValue = normalizeValue $ pst <> minAda
+
+    proposalBuilder :: b
+    proposalBuilder =
+      mconcat
+        [ input $
+            mconcat
+              [ script proposalValidatorHash
+              , withValue proposalValue
+              , withDatum proposalInputDatum
+              , withRef proposalRef
+              , withRedeemer proposalRedeemer
+              ]
+        , output $
+            mconcat
+              [ script proposalValidatorHash
+              , withValue proposalValue
+              , withDatum proposalOutputDatum
+              ]
+        ]
+
+    ---
+
+    sst = Value.assetClassValue stakeAssetClass 1
+
+    stakeInputDatum = mkStakeInputDatum ps.stakeParameters
+
+    removeLocks v c =
+      filter $
+        not
+          . ( \case
+                Created pid -> c && pid == defProposalId
+                Voted pid _ -> v && pid == defProposalId
+            )
+
+    stakeOutputDatum =
+      stakeInputDatum
+        { lockedBy =
+            removeLocks
+              ps.stakeParameters.removeVoterLock
+              ps.stakeParameters.removeCreatorLock
+              stakeInputDatum.lockedBy
+        }
+
+    mkStakeValue gt =
+      normalizeValue $
+        mconcat
+          [ minAda
+          , sst
+          , Value.assetClassValue
+              (untag governor.gtClassRef)
+              gt
+          ]
+
+    stakeInputValue = mkStakeValue defStakedGTs
+
+    stakeOutputValue =
+      mkStakeValue $
+        if ps.stakeParameters.alterOutputValue
+          then alteredStakedGTs
+          else defStakedGTs
+
+    stakeBuilder :: b
+    stakeBuilder =
+      foldMap
+        ( \i ->
+            mconcat
+              [ input $
+                  mconcat
+                    [ script stakeValidatorHash
+                    , withValue stakeInputValue
+                    , withDatum stakeInputDatum
+                    , withRef $ mkStakeRef i
+                    ]
+              , output $
+                  mconcat
+                    [ script stakeValidatorHash
+                    , withValue stakeOutputValue
+                    , withDatum stakeOutputDatum
+                    ]
+              ]
+        )
+        [1 .. ps.stakeParameters.numStakes]
+
+    ---
+
+    time = case ps.transactionParameters.timeRange of
+      WhileVoting ->
+        closedBoundedInterval
+          ((def :: ProposalTimingConfig).draftTime + 1)
+          ((def :: ProposalTimingConfig).votingTime - 1)
+      AfterVoting ->
+        closedBoundedInterval
+          ((def :: ProposalTimingConfig).votingTime + 1)
+          ((def :: ProposalTimingConfig).lockingTime - 1)
+
+    sig = case ps.transactionParameters.signedBy of
+      Unknown -> defUnknown
+      Owner -> defOwner
+      Delegatee -> defDelegatee
+
+    ---
+
+    builder =
+      mconcat
+        [ txId "388bc0b897b3dadcd479da4c88291de4113a50b72ddbed001faf7fc03f11bc52"
+        , proposalBuilder
+        , stakeBuilder
+        , signedWith sig
+        , timeRange time
+        ]
+
+--------------------------------------------------------------------------------
+
+{- | Create a test tree that runs both the stake validator and the proposal
+     validator.
+-}
+mkTestTree :: String -> ParameterBundle -> Validity -> SpecificationTree
+mkTestTree name ps val = group name [stake, proposal]
+  where
+    spend = mkSpending unlock ps
+
+    stake =
+      testValidator
+        val.forStakeValidator
+        "stake"
+        agoraScripts.compiledStakeValidator
+        (mkStakeInputDatum ps.stakeParameters)
+        stakeRedeemer
+        (spend $ mkStakeRef 1)
+
+    proposal =
+      testValidator
+        val.forProposalValidator
+        "proposal"
+        agoraScripts.compiledProposalValidator
+        (mkProposalInputDatum ps.stakeParameters ps.proposalParameters)
+        proposalRedeemer
+        (spend proposalRef)
+
+--------------------------------------------------------------------------------
+
+mkValidVoterRetractVotes :: Integer -> ParameterBundle
+mkValidVoterRetractVotes i =
+  ParameterBundle
+    { proposalParameters =
+        ProposalParameters
+          { proposalStatus = VotingReady
+          , retractVotes = True
+          }
+    , stakeParameters =
+        StakeParameters
+          { numStakes = i
+          , stakeRole = Voter
+          , removeVoterLock = True
+          , removeCreatorLock = False
+          , alterOutputValue = False
+          }
+    , transactionParameters =
+        TransactionParameters
+          { signedBy = Owner
+          , timeRange =
+              WhileVoting
+          }
+    }
+
+mkValidDelegateeRetractVotes :: Integer -> ParameterBundle
+mkValidDelegateeRetractVotes i =
+  let template = mkValidVoterRetractVotes i
+   in template
+        { transactionParameters =
+            template.transactionParameters
+              { signedBy = Delegatee
+              }
+        }
+
+mkValidVoterCreatorRetractVotes :: Integer -> ParameterBundle
+mkValidVoterCreatorRetractVotes i =
+  let template = mkValidVoterRetractVotes i
+   in template
+        { stakeParameters =
+            template.stakeParameters
+              { stakeRole = Both
+              }
+        }
+
+mkValidCreatorRemoveLock :: Integer -> ParameterBundle
+mkValidCreatorRemoveLock i =
+  let template = mkValidVoterRetractVotes i
+   in template
+        { proposalParameters =
+            template.proposalParameters
+              { proposalStatus = Finished
+              , retractVotes = False
+              }
+        , stakeParameters =
+            template.stakeParameters
+              { stakeRole = Creator
+              , removeCreatorLock = True
+              }
+        , transactionParameters =
+            template.transactionParameters
+              { timeRange = AfterVoting
+              }
+        }
+
+mkValidVoterRemoveLockAfterVoting :: Integer -> ParameterBundle
+mkValidVoterRemoveLockAfterVoting i =
+  let template = mkValidVoterRetractVotes i
+   in template
+        { proposalParameters =
+            template.proposalParameters
+              { proposalStatus = Finished
+              , retractVotes = False
+              }
+        , transactionParameters =
+            template.transactionParameters
+              { timeRange = AfterVoting
+              }
+        }
+
+mkRetractVotesWhileNotVoting :: Integer -> [ParameterBundle]
+mkRetractVotesWhileNotVoting i =
+  let template = mkValidVoterRetractVotes i
+   in map
+        ( \s ->
+            template
+              { proposalParameters =
+                  template.proposalParameters
+                    { proposalStatus = s
+                    }
+              }
+        )
+        [Draft, Locked, Finished]
+
+mkUnockIrrelevantStakes :: Integer -> ParameterBundle
+mkUnockIrrelevantStakes i =
+  let template = mkValidVoterRetractVotes i
+   in template
+        { stakeParameters =
+            template.stakeParameters
+              { stakeRole = Irrelevant
+              , removeCreatorLock = True
+              }
+        }
+
+mkRemoveCreatorLockBeforeFinished :: Integer -> [ParameterBundle]
+mkRemoveCreatorLockBeforeFinished i =
+  let template = mkValidCreatorRemoveLock i
+   in map
+        ( \s ->
+            template
+              { proposalParameters =
+                  template.proposalParameters
+                    { proposalStatus = s
+                    }
+              }
+        )
+        [Draft, VotingReady, Locked]
+
+mkCreatorRetractVotes :: Integer -> ParameterBundle
+mkCreatorRetractVotes i =
+  let template = mkValidVoterRetractVotes i
+   in template
+        { proposalParameters =
+            template.proposalParameters
+              { proposalStatus = VotingReady
+              }
+        , stakeParameters =
+            template.stakeParameters
+              { stakeRole = Creator
+              }
+        , transactionParameters =
+            template.transactionParameters
+              { timeRange = WhileVoting
+              }
+        }
+
+mkChangeOutputStakeValue :: Integer -> ParameterBundle
+mkChangeOutputStakeValue i =
+  let template = mkValidVoterRetractVotes i
+   in template
+        { stakeParameters =
+            template.stakeParameters
+              { alterOutputValue = True
+              }
+        }

agora-specs/Sample/Proposal/UnlockStake.hs

@@ -1,559 +0,0 @@
-{- |
-Module     : Sample.Proposal.UnlockStake
-Maintainer : connor@mlabs.city
-Description: Generate sample data for testing the functionalities of unlocking stake and retracting votes
-
-Sample and utilities for testing the functionalities of unlocking stake and retracting votes
--}
-module Sample.Proposal.UnlockStake (
-  StakeRole (..),
-  Parameters (..),
-  unlockStake,
-  mkTestTree,
-  mkVoterRetractVotesWhileVotingParameters,
-  mkVoterCreatorRetractVotesWhileVotingParameters,
-  mkCreatorRemoveCreatorLocksWhenFinishedParameters,
-  mkVoterCreatorRemoveAllLocksWhenFinishedParameters,
-  mkVoterUnlockStakeAfterVotingParameters,
-  mkVoterCreatorRemoveVoteLocksWhenLockedParameters,
-  mkRetractVotesWhileNotVoting,
-  mkUnockIrrelevantStakeParameters,
-  mkRemoveCreatorLockBeforeFinishedParameters,
-  mkRetractVotesWithCreatorStakeParamaters,
-  mkAlterStakeParameters,
-) where
-
---------------------------------------------------------------------------------
-
-import Agora.Governor (Governor (..))
-import Agora.Proposal (
-  ProposalDatum (..),
-  ProposalEffectGroup,
-  ProposalId (..),
-  ProposalRedeemer (Unlock),
-  ProposalStatus (..),
-  ProposalVotes (..),
-  ResultTag (..),
- )
-import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime))
-import Agora.SafeMoney (GTTag)
-import Agora.Scripts (AgoraScripts (..))
-import Agora.Stake (
-  ProposalLock (..),
-  StakeDatum (..),
-  StakeRedeemer (RetractVotes),
- )
-import Data.Default.Class (Default (def))
-import Data.Map.Strict qualified as StrictMap
-import Data.Tagged (untag)
-import Plutarch.Context (
-  input,
-  output,
-  script,
-  signedWith,
-  txId,
-  withDatum,
-  withRedeemer,
-  withRef,
-  withValue,
- )
-import Plutarch.SafeMoney (Discrete)
-import PlutusLedgerApi.V1.Value qualified as Value
-import PlutusLedgerApi.V2 (
-  Credential (PubKeyCredential),
-  PubKeyHash,
-  TxOutRef (..),
- )
-import Sample.Proposal.Shared (stakeTxRef)
-import Sample.Shared (
-  agoraScripts,
-  fromDiscrete,
-  governor,
-  minAda,
-  proposalPolicySymbol,
-  proposalValidatorHash,
-  signer,
-  stakeAssetClass,
-  stakeValidatorHash,
- )
-import Test.Specification (SpecificationTree, group, testValidator)
-import Test.Util (CombinableBuilder, mkSpending, sortValue)
-
---------------------------------------------------------------------------------
-
--- | The template "shape" that votes of proposals generated by 'mkProposalDatumPair' have.
-votesTemplate :: ProposalVotes
-votesTemplate =
-  ProposalVotes $
-    StrictMap.fromList
-      [ (ResultTag 0, 0)
-      , (ResultTag 1, 0)
-      ]
-
--- | Create empty effects for every result tag given the votes.
-emptyEffectFor ::
-  ProposalVotes ->
-  StrictMap.Map ResultTag ProposalEffectGroup
-emptyEffectFor (ProposalVotes vs) =
-  StrictMap.fromList $
-    map (,StrictMap.empty) (StrictMap.keys vs)
-
--- | The default vote option that will be used by functions in this module.
-defVoteFor :: ResultTag
-defVoteFor = ResultTag 0
-
--- | The default number of GTs the stake will have.
-defStakedGTs :: Discrete GTTag
-defStakedGTs = 100000
-
-{- | If 'Parameters.alterOutputStake' is set to true, the
-     'StakeDatum.stakedAmount' will be set to this.
--}
-alteredStakedGTs :: Discrete GTTag
-alteredStakedGTs = 100
-
--- | Default owner of the stakes.
-defOwner :: PubKeyHash
-defOwner = signer
-
--- | How a stake has been used on a particular proposal.
-data StakeRole
-  = -- | The stake was spent to vote for a paraticular option.
-    Voter
-  | -- | The stake was used to create the proposal.
-    Creator
-  | -- | The stake was used to both create and vote for the proposal.
-    Both
-  | -- | The stake has nothing to do with the proposal.
-    Irrelevant
-  deriving stock (Bounded, Enum, Show)
-
--- | Parameters for creating a 'TxOut' that unlocks a stake.
-data Parameters = Parameters
-  { proposalCount :: Integer
-  -- ^ The number of proposals in the 'TxOut'.
-  , stakeRole :: StakeRole
-  -- ^ The role of the stake we're unlocking.
-  , retractVotes :: Bool
-  -- ^ Whether to retract votes or not.
-  , removeVoterLock :: Bool
-  -- ^ Remove the voter locks from the input stake.
-  , removeCreatorLock :: Bool
-  -- ^ Remove the creator locks from the input stake.
-  , proposalStatus :: ProposalStatus
-  -- ^ The state of all the proposals.
-  , alterOutputStake :: Bool
-  }
-
--- | Iterate over the proposal id of every proposal, given the number of proposals.
-forEachProposalId :: Parameters -> (ProposalId -> a) -> [a]
-forEachProposalId ps = forEachProposalId' ps.proposalCount
-  where
-    forEachProposalId' :: Integer -> (ProposalId -> a) -> [a]
-    forEachProposalId' 0 _ = error "zero proposal"
-    forEachProposalId' n f = f . ProposalId <$> [0 .. n - 1]
-
--- | Create locks for the input stake given the parameters.
-mkInputStakeLocks :: Parameters -> [ProposalLock]
-mkInputStakeLocks ps = mconcat $ forEachProposalId ps $ mkStakeLocksFor ps.stakeRole
-  where
-    mkStakeLocksFor :: StakeRole -> ProposalId -> [ProposalLock]
-    mkStakeLocksFor sr pid =
-      let voted = [Voted pid defVoteFor]
-          created = [Created pid]
-       in case sr of
-            Voter -> voted
-            Creator -> created
-            Both -> voted <> created
-            _ -> []
-
--- | Create locks for the output stake by removing locks from the input locks.
-mkOutputStakeLocks :: Parameters -> [ProposalLock]
-mkOutputStakeLocks ps =
-  filter
-    ( \lock -> not $ case lock of
-        Voted _ _ -> ps.removeVoterLock
-        Created _ -> ps.removeCreatorLock
-    )
-    inputLocks
-  where
-    inputLocks = mkInputStakeLocks ps
-
--- | Create the stake input datum given the parameters.
-mkStakeInputDatum :: Parameters -> StakeDatum
-mkStakeInputDatum ps =
-  StakeDatum
-    { stakedAmount = defStakedGTs
-    , owner = PubKeyCredential defOwner
-    , delegatedTo = Nothing
-    , lockedBy = mkInputStakeLocks ps
-    }
-
--- | Create stake output datum given the parameters.
-mkStakeOutputDatum :: Parameters -> StakeDatum
-mkStakeOutputDatum ps =
-  let template = mkStakeInputDatum ps
-      stakedAmount' =
-        if ps.alterOutputStake
-          then alteredStakedGTs
-          else defStakedGTs
-   in template
-        { stakedAmount = stakedAmount'
-        , lockedBy = mkOutputStakeLocks ps
-        }
-
--- | Generate some input proposals and their corresponding output proposals.
-mkProposals :: Parameters -> [(ProposalDatum, ProposalDatum)]
-mkProposals ps = forEachProposalId ps $ mkProposalDatumPair ps
-
--- | Create the input proposal datum.
-mkProposalInputDatum :: Parameters -> ProposalId -> ProposalDatum
-mkProposalInputDatum p pid = fst $ mkProposalDatumPair p pid
-
--- | Create a input proposal and its corresponding output proposal.
-mkProposalDatumPair ::
-  Parameters ->
-  ProposalId ->
-  (ProposalDatum, ProposalDatum)
-mkProposalDatumPair params pid =
-  let inputVotes = mkInputVotes params.stakeRole $ fromDiscrete defStakedGTs
-
-      input =
-        ProposalDatum
-          { proposalId = pid
-          , effects = emptyEffectFor votesTemplate
-          , status = params.proposalStatus
-          , cosigners = [PubKeyCredential defOwner]
-          , thresholds = def
-          , votes = inputVotes
-          , timingConfig = def
-          , startingTime = ProposalStartingTime 0
-          }
-
-      output =
-        if params.retractVotes
-          then input {votes = votesTemplate}
-          else input
-   in (input, output)
-  where
-    -- Assemble the votes of the input proposal based on 'votesTemplate'.
-    mkInputVotes ::
-      StakeRole ->
-      -- The staked amount/votes.
-      Integer ->
-      ProposalVotes
-    mkInputVotes Creator _ =
-      ProposalVotes $
-        StrictMap.adjust (const 1000) defVoteFor $
-          votesTemplate.getProposalVotes
-    mkInputVotes Irrelevant _ = votesTemplate
-    mkInputVotes _ vc =
-      ProposalVotes $
-        StrictMap.adjust (const vc) defVoteFor $
-          votesTemplate.getProposalVotes
-
--- | Create a 'TxInfo' that tries to unlock a stake.
-unlockStake :: forall b. CombinableBuilder b => Parameters -> b
-unlockStake ps =
-  let pst = Value.singleton proposalPolicySymbol "" 1
-      sst = Value.assetClassValue stakeAssetClass 1
-
-      pIODatums = mkProposals ps
-
-      proposals =
-        foldMap
-          ( \((i, o), idx) ->
-              mconcat
-                [ input $
-                    mconcat
-                      [ script proposalValidatorHash
-                      , withValue pst
-                      , withDatum i
-                      , withRef (mkProposalRef idx)
-                      , withRedeemer proposalRedeemer
-                      ]
-                , output $
-                    mconcat
-                      [ script proposalValidatorHash
-                      , withValue (sortValue $ pst <> minAda)
-                      , withDatum o
-                      ]
-                ]
-          )
-          (zip pIODatums [0 ..])
-
-      stakeValue =
-        sortValue $
-          mconcat
-            [ Value.assetClassValue
-                (untag governor.gtClassRef)
-                (fromDiscrete defStakedGTs)
-            , sst
-            , minAda
-            ]
-
-      sInDatum = mkStakeInputDatum ps
-      sOutDatum = mkStakeOutputDatum ps
-
-      stakes =
-        mconcat
-          [ input $
-              mconcat
-                [ script stakeValidatorHash
-                , withValue stakeValue
-                , withDatum sInDatum
-                , withRef stakeRef
-                ]
-          , output $
-              mconcat
-                [ script stakeValidatorHash
-                , withValue stakeValue
-                , withDatum sOutDatum
-                ]
-          ]
-
-      builder =
-        mconcat
-          [ txId "388bc0b897b3dadcd479da4c88291de4113a50b72ddbed001faf7fc03f11bc52"
-          , proposals
-          , stakes
-          , signedWith defOwner
-          ]
-   in builder
-
--- | Reference to the stake UTXO.
-stakeRef :: TxOutRef
-stakeRef = TxOutRef stakeTxRef 1
-
--- | Generate the reference to a proposal UTXOs, given the index of the proposal.
-mkProposalRef :: Int -> TxOutRef
-mkProposalRef offset = TxOutRef stakeTxRef $ 2 + fromIntegral offset
-
--- | Proposal redeemer used by 'mkTestTree', in this case it's always 'Unlock'.
-proposalRedeemer :: ProposalRedeemer
-proposalRedeemer = Unlock
-
--- | Stake redeemer used by 'mkTestTree', in this case it's always 'RetractVotes'.
-stakeRedeemer :: StakeRedeemer
-stakeRedeemer = RetractVotes
-
---------------------------------------------------------------------------------
-
-{- | Legal parameters that retract votes while the proposals is in 'VotingReady'
-      state, and also remove voter locks from the stake, which is
-      used to vote on the proposals.
--}
-mkVoterRetractVotesWhileVotingParameters :: Integer -> Parameters
-mkVoterRetractVotesWhileVotingParameters nProposals =
-  Parameters
-    { proposalCount = nProposals
-    , stakeRole = Voter
-    , retractVotes = True
-    , removeVoterLock = True
-    , removeCreatorLock = False
-    , proposalStatus = VotingReady
-    , alterOutputStake = False
-    }
-
-{- | Legal parameters that retract votes while the proposals is in 'VotingReady'
-      state, and also remove voter locks from the stake, which is
-      used to both create and vote on the proposals.
--}
-mkVoterCreatorRetractVotesWhileVotingParameters :: Integer -> Parameters
-mkVoterCreatorRetractVotesWhileVotingParameters nProposals =
-  Parameters
-    { proposalCount = nProposals
-    , stakeRole = Both
-    , retractVotes = True
-    , removeVoterLock = True
-    , removeCreatorLock = False
-    , proposalStatus = VotingReady
-    , alterOutputStake = False
-    }
-
-{- | Legal parameters that remove creator locks from the stake while the
-      proposals is in 'Finished' state. The stake was only used for creating
-      the proposals.
--}
-mkCreatorRemoveCreatorLocksWhenFinishedParameters :: Integer -> Parameters
-mkCreatorRemoveCreatorLocksWhenFinishedParameters nProposals =
-  Parameters
-    { proposalCount = nProposals
-    , stakeRole = Creator
-    , retractVotes = False
-    , removeVoterLock = False
-    , removeCreatorLock = True
-    , proposalStatus = Finished
-    , alterOutputStake = False
-    }
-
-{- | Legal parameters that remove voter and creator locks from the stake while
-      the proposals is in 'Finished' state. The stake was used for creating
-      and voting on the proposals.
--}
-mkVoterCreatorRemoveAllLocksWhenFinishedParameters :: Integer -> Parameters
-mkVoterCreatorRemoveAllLocksWhenFinishedParameters nProposals =
-  Parameters
-    { proposalCount = nProposals
-    , stakeRole = Both
-    , retractVotes = False
-    , removeVoterLock = True
-    , removeCreatorLock = True
-    , proposalStatus = Finished
-    , alterOutputStake = False
-    }
-
-{- Legal parameters that remove voter locks from the stake after the voting
-    phrase. The stake was used only for voting on the proposals.
--}
-mkVoterUnlockStakeAfterVotingParameters :: Integer -> [Parameters]
-mkVoterUnlockStakeAfterVotingParameters nProposals =
-  map
-    ( \st ->
-        Parameters
-          { proposalCount = nProposals
-          , stakeRole = Voter
-          , retractVotes = False
-          , removeVoterLock = True
-          , removeCreatorLock = False
-          , proposalStatus = st
-          , alterOutputStake = False
-          }
-    )
-    [Locked, Finished]
-
-{- Legal parameters that remove voter locks whenproposals are in phrase.
-    The stake was used for crating and voting on the proposals.
--}
-mkVoterCreatorRemoveVoteLocksWhenLockedParameters :: Integer -> Parameters
-mkVoterCreatorRemoveVoteLocksWhenLockedParameters nProposals =
-  Parameters
-    { proposalCount = nProposals
-    , stakeRole = Both
-    , retractVotes = False
-    , removeVoterLock = True
-    , removeCreatorLock = False
-    , proposalStatus = Locked
-    , alterOutputStake = False
-    }
-
-{- | Illegal parameters that retract votes when the proposals are not in voting
-      phrase.
--}
-mkRetractVotesWhileNotVoting :: Integer -> [Parameters]
-mkRetractVotesWhileNotVoting nProposals = do
-  role <- enumFrom Voter
-  status <- [Draft, Locked, Finished]
-
-  pure $
-    Parameters
-      { proposalCount = nProposals
-      , stakeRole = role
-      , retractVotes = True
-      , removeVoterLock = True
-      , removeCreatorLock = False
-      , proposalStatus = status
-      , alterOutputStake = False
-      }
-
-{- | Illegal parameter that try to unlock a stake that has nothing to do with
-      the proposals.
--}
-mkUnockIrrelevantStakeParameters :: Integer -> [Parameters]
-mkUnockIrrelevantStakeParameters nProposals = do
-  status <- [Draft, VotingReady, Locked, Finished]
-  retractVotes <- [True, False]
-
-  pure $
-    Parameters
-      { proposalCount = nProposals
-      , stakeRole = Irrelevant
-      , retractVotes = retractVotes
-      , removeVoterLock = True
-      , removeCreatorLock = True
-      , proposalStatus = status
-      , alterOutputStake = False
-      }
-
-{- | Illegal parameters that remove the creator locks before the proposals are
-      'Finished'.
--}
-mkRemoveCreatorLockBeforeFinishedParameters :: Integer -> [Parameters]
-mkRemoveCreatorLockBeforeFinishedParameters nProposals = do
-  status <- [Draft, VotingReady, Locked]
-
-  pure $
-    Parameters
-      { proposalCount = nProposals
-      , stakeRole = Creator
-      , retractVotes = False
-      , removeVoterLock = False
-      , removeCreatorLock = True
-      , proposalStatus = status
-      , alterOutputStake = False
-      }
-
-{- | Illegal parameters that try to retract votes with a stake that was only used
-    for creating the proposals.
--}
-mkRetractVotesWithCreatorStakeParamaters :: Integer -> Parameters
-mkRetractVotesWithCreatorStakeParamaters nProposals =
-  Parameters
-    { proposalCount = nProposals
-    , stakeRole = Creator
-    , retractVotes = True
-    , removeVoterLock = True
-    , removeCreatorLock = True
-    , proposalStatus = VotingReady
-    , alterOutputStake = False
-    }
-
-{- | Illegal parameters that try to change the 'StakeDatum.stakedAmount' field of
-      the output stake datum.
--}
-mkAlterStakeParameters :: Integer -> [Parameters]
-mkAlterStakeParameters nProposals = do
-  role <- enumFrom Voter
-  status <- [Draft, Locked, Finished]
-
-  pure $
-    Parameters
-      { proposalCount = nProposals
-      , stakeRole = role
-      , retractVotes = True
-      , removeVoterLock = True
-      , removeCreatorLock = False
-      , proposalStatus = status
-      , alterOutputStake = True
-      }
-
---------------------------------------------------------------------------------
-
-{- | Create a test tree that runs both the stake validator and the proposal
-     validator.
--}
-mkTestTree :: String -> Parameters -> Bool -> SpecificationTree
-mkTestTree name ps isValid = group name [stake, proposal]
-  where
-    spend = mkSpending unlockStake ps
-
-    stake =
-      testValidator
-        (not ps.alterOutputStake)
-        "stake"
-        agoraScripts.compiledStakeValidator
-        (mkStakeInputDatum ps)
-        stakeRedeemer
-        (spend stakeRef)
-
-    proposal =
-      let idx = 0
-          pid = ProposalId $ fromIntegral idx
-          ref = mkProposalRef idx
-       in testValidator
-            isValid
-            "proposal"
-            agoraScripts.compiledProposalValidator
-            (mkProposalInputDatum ps pid)
-            proposalRedeemer
-            (spend ref)

agora-specs/Spec/Proposal.hs

@@ -10,10 +10,9 @@ module Spec.Proposal (specs) where
 import Sample.Proposal.Advance qualified as Advance
 import Sample.Proposal.Cosign qualified as Cosign
 import Sample.Proposal.Create qualified as Create
-import Sample.Proposal.UnlockStake qualified as UnlockStake
+import Sample.Proposal.Unlock qualified as Unlock
 import Sample.Proposal.Vote qualified as Vote
 
--- import Sample.Proposal.UnlockStake qualified as UnlockStake
 import Test.Specification (
   SpecificationTree,
   group,
@@ -324,103 +323,72 @@ specs =
                           ]
                       ]
       , group "unlocking" $
-          let proposalCountCases = [1, 5, 10, 42]
+          let stakeCountCases = [1, 3, 5, 7, 9, 11]
 
-              mkSubgroupName nProposals = unwords ["with", show nProposals, "proposals"]
+              mkSubgroupName nStakes = unwords ["with", show nStakes, "stakes"]
 
-              mkLegalGroup nProposals =
+              mkLegalGroup nStakes =
                 group
-                  (mkSubgroupName nProposals)
-                  [ UnlockStake.mkTestTree
+                  (mkSubgroupName nStakes)
+                  [ Unlock.mkTestTree
                       "voter: retract votes while voting"
-                      (UnlockStake.mkVoterRetractVotesWhileVotingParameters nProposals)
-                      True
-                  , UnlockStake.mkTestTree
+                      (Unlock.mkValidVoterRetractVotes nStakes)
+                      (Unlock.Validity True True)
+                  , Unlock.mkTestTree
+                      "voter: retract votes while voting by delegatee"
+                      (Unlock.mkValidDelegateeRetractVotes nStakes)
+                      (Unlock.Validity True True)
+                  , Unlock.mkTestTree
                       "voter/creator: retract votes while voting"
-                      (UnlockStake.mkVoterCreatorRetractVotesWhileVotingParameters nProposals)
-                      True
-                  , UnlockStake.mkTestTree
-                      "creator: remove creator locks when finished"
-                      (UnlockStake.mkCreatorRemoveCreatorLocksWhenFinishedParameters nProposals)
-                      True
-                  , UnlockStake.mkTestTree
-                      "voter/creator: remove all locks when finished"
-                      (UnlockStake.mkVoterCreatorRemoveAllLocksWhenFinishedParameters nProposals)
-                      True
-                  , group "voter: unlock after voting" $
-                      map
-                        ( \ps ->
-                            let name = show ps.proposalStatus
-                             in UnlockStake.mkTestTree name ps True
-                        )
-                        (UnlockStake.mkVoterUnlockStakeAfterVotingParameters nProposals)
-                  , UnlockStake.mkTestTree
-                      "voter/creator: remove vote locks when locked"
-                      (UnlockStake.mkVoterCreatorRemoveVoteLocksWhenLockedParameters nProposals)
-                      True
+                      (Unlock.mkValidVoterCreatorRetractVotes nStakes)
+                      (Unlock.Validity True True)
+                  , Unlock.mkTestTree
+                      "creator: remove creator lock after voting"
+                      (Unlock.mkValidCreatorRemoveLock nStakes)
+                      (Unlock.Validity True True)
+                  , Unlock.mkTestTree
+                      "Voter: remove lock after voting"
+                      (Unlock.mkValidVoterRemoveLockAfterVoting nStakes)
+                      (Unlock.Validity True True)
                   ]
 
-              mkIllegalGroup nProposals =
+              mkIllegalGroup nStakes =
                 group
-                  (mkSubgroupName nProposals)
+                  (mkSubgroupName nStakes)
                   [ group "retract votes while not voting" $
                       map
-                        ( \ps ->
-                            let name =
-                                  unwords
-                                    [ "role:"
-                                    , show ps.stakeRole
-                                    , ","
-                                    , "status:"
-                                    , show ps.proposalStatus
-                                    ]
-                             in UnlockStake.mkTestTree name ps False
+                        ( \c ->
+                            Unlock.mkTestTree
+                              "(negative test)"
+                              c
+                              (Unlock.Validity False True)
                         )
-                        (UnlockStake.mkRetractVotesWhileNotVoting nProposals)
-                  , group "unlock an irrelevant stake" $
-                      map
-                        ( \ps ->
-                            let name =
-                                  unwords
-                                    [ "status:"
-                                    , show ps.proposalStatus
-                                    , "retract votes:"
-                                    , show ps.retractVotes
-                                    ]
-                             in UnlockStake.mkTestTree name ps False
-                        )
-                        (UnlockStake.mkUnockIrrelevantStakeParameters nProposals)
+                        (Unlock.mkRetractVotesWhileNotVoting nStakes)
                   , group "remove creator too early" $
                       map
-                        ( \ps ->
-                            let name =
-                                  unwords
-                                    ["status:", show ps.proposalStatus]
-                             in UnlockStake.mkTestTree name ps False
+                        ( \c ->
+                            Unlock.mkTestTree
+                              "(negative test)"
+                              c
+                              (Unlock.Validity True False)
                         )
-                        (UnlockStake.mkRemoveCreatorLockBeforeFinishedParameters nProposals)
-                  , UnlockStake.mkTestTree
+                        (Unlock.mkRemoveCreatorLockBeforeFinished nStakes)
+                  , Unlock.mkTestTree
+                      "unlock an irrelevant stake"
+                      (Unlock.mkUnockIrrelevantStakes nStakes)
+                      (Unlock.Validity False True)
+                  , Unlock.mkTestTree
                       "creator: retract votes"
-                      (UnlockStake.mkRetractVotesWithCreatorStakeParamaters nProposals)
-                      False
-                  , group "alter output stake datum" $
-                      map
-                        ( \ps ->
-                            let name =
-                                  unwords
-                                    [ "role:"
-                                    , show ps.stakeRole
-                                    , ","
-                                    , "status:"
-                                    , show ps.proposalStatus
-                                    ]
-                             in UnlockStake.mkTestTree name ps False
-                        )
-                        (UnlockStake.mkAlterStakeParameters nProposals)
+                      (Unlock.mkCreatorRetractVotes nStakes)
+                      (Unlock.Validity False True)
+                  , Unlock.mkTestTree
+                      "change output stake value"
+                      (Unlock.mkChangeOutputStakeValue nStakes)
+                      (Unlock.Validity True False)
                   ]
 
-              legalGroup = group "legal" $ map mkLegalGroup proposalCountCases
-              illegalGroup = group "illegal" $ map mkIllegalGroup proposalCountCases
+              legalGroup = group "legal" $ map mkLegalGroup stakeCountCases
+              illegalGroup = group "illegal" $ map mkIllegalGroup stakeCountCases
            in [legalGroup, illegalGroup]
       ]
   ]

agora.cabal

@@ -198,7 +198,7 @@ library agora-specs
     Sample.Proposal.Cosign
     Sample.Proposal.Create
     Sample.Proposal.Shared
-    Sample.Proposal.UnlockStake
+    Sample.Proposal.Unlock
     Sample.Proposal.Vote
     Sample.Shared
     Sample.Stake