diff --git a/agora.cabal b/agora.cabal index 4e0c1aa..c6d3061 100644 --- a/agora.cabal +++ b/agora.cabal @@ -79,6 +79,7 @@ common deps , serialise , template-haskell , text + , generics-sop common test-deps build-depends: @@ -95,6 +96,8 @@ library import: lang, deps exposed-modules: Agora.AuthorityToken + Agora.Stake + Agora.Voting Agora.SafeMoney Agora.SafeMoney.QQ other-modules: diff --git a/flake.lock b/flake.lock index 7dc3852..b5acf55 100644 --- a/flake.lock +++ b/flake.lock @@ -1400,7 +1400,6 @@ "hercules-ci-effects": "hercules-ci-effects", "hs-memory": "hs-memory", "nixpkgs": [ - "plutarch", "haskell-nix", "nixpkgs-unstable" ], @@ -1410,17 +1409,17 @@ "th-extras": "th-extras" }, "locked": { - "lastModified": 1643799364, - "narHash": "sha256-ud/YkMtBKcx0yrHOboA7uTPtGCt5LCOipF0m2W6LqxU=", + "lastModified": 1644875667, + "narHash": "sha256-eNKEubOfkVGmDX1HbbCTbtIjEyXfxlYedrWuwhOLVrQ=", "owner": "Plutonomicon", "repo": "plutarch", - "rev": "1fd4db27152625184e559cfb465d225a0995a56b", + "rev": "a0cbe99921aad7c5df9239cb0240933e4d9b2eaa", "type": "github" }, "original": { "owner": "Plutonomicon", "repo": "plutarch", - "rev": "1fd4db27152625184e559cfb465d225a0995a56b", + "rev": "a0cbe99921aad7c5df9239cb0240933e4d9b2eaa", "type": "github" } }, diff --git a/flake.nix b/flake.nix index e4751d7..17c8997 100644 --- a/flake.nix +++ b/flake.nix @@ -13,7 +13,7 @@ "github:input-output-hk/plutus?rev=65bad0fd53e432974c3c203b1b1999161b6c2dce"; inputs.plutarch.url = - "github:Plutonomicon/plutarch?rev=1fd4db27152625184e559cfb465d225a0995a56b"; + "github:Plutonomicon/plutarch?rev=a0cbe99921aad7c5df9239cb0240933e4d9b2eaa"; inputs.goblins.url = "github:input-output-hk/goblins?rev=cde90a2b27f79187ca8310b6549331e59595e7ba"; diff --git a/src/Agora/AuthorityToken.hs b/src/Agora/AuthorityToken.hs index cd87c28..913ff0b 100644 --- a/src/Agora/AuthorityToken.hs +++ b/src/Agora/AuthorityToken.hs @@ -37,9 +37,9 @@ newtype AuthorityToken = AuthorityToken authorityTokenPolicy :: AuthorityToken -> - Term s (PData :--> PData :--> PScriptContext :--> PUnit) + Term s (PData :--> PScriptContext :--> PUnit) authorityTokenPolicy params = - plam $ \_datum _redeemer ctx' -> + plam $ \_redeemer ctx' -> pmatch ctx' $ \(PScriptContext ctx) -> let txInfo' = pfromData $ pfield @"txInfo" # ctx purpose' = pfromData $ pfield @"purpose" # ctx diff --git a/src/Agora/Stake.hs b/src/Agora/Stake.hs new file mode 100644 index 0000000..34dddc9 --- /dev/null +++ b/src/Agora/Stake.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE PolyKinds #-} + +-- | Vote-lockable stake UTXOs holding GT +module Agora.Stake ( + StakeDatum (..), + StakeAction (..), + Stake (..), + stakePolicy, +) where + +-------------------------------------------------------------------------------- + +import GHC.Generics qualified as GHC +import Generics.SOP (Generic, I (I)) +import Prelude + +-------------------------------------------------------------------------------- + +import Plutarch.Api.V1 +import Plutarch.DataRepr ( + PDataFields, + PIsDataReprInstances (PIsDataReprInstances), + ) +import Plutarch.Internal +import Plutarch.Prelude + +-------------------------------------------------------------------------------- + +import Agora.SafeMoney + +-------------------------------------------------------------------------------- + +data Stake (gt :: MoneyClass) = Stake + +data StakeAction (gt :: MoneyClass) (s :: S) + = -- | Deposit or withdraw a discrete amount of the staked governance token + DepositWithdraw (Term s (PDataRecord '["delta" ':= Discrete gt])) + | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets + Destroy (Term s (PDataRecord '[])) + deriving stock (GHC.Generic) + deriving anyclass (Generic) + deriving anyclass (PIsDataRepr) + deriving + (PlutusType, PIsData) + via PIsDataReprInstances (StakeAction gt) + +newtype StakeDatum (gt :: MoneyClass) (s :: S) = StakeDatum + { getStakeDatum :: + ( Term + s + ( PDataRecord + '[ "stakedAmount" ':= Discrete gt + , "owner" ':= PPubKeyHash + ] + ) + ) + } + deriving stock (GHC.Generic) + deriving anyclass (Generic) + deriving anyclass (PIsDataRepr) + deriving + (PlutusType, PIsData, PDataFields) + via (PIsDataReprInstances (StakeDatum gt)) + +assert :: Term s PString -> Term s PBool -> TermCont @r s () +assert errorMessage check = TermCont $ \k -> pif check (k ()) (ptraceError errorMessage) + +pfindDatum :: Term s (PDatumHash :--> PTxInfo :--> PMaybe PDatum) +pfindDatum = phoistAcyclic $ + plam $ \_datumHash _txInfo -> unTermCont $ do + pure (pcon PNothing) + +stakePolicy :: + forall (gt :: MoneyClass) s. + Stake gt -> + Term s (PData :--> PScriptContext :--> PUnit) +stakePolicy _stake = + plam $ \_redeemer ctx -> unTermCont $ do + PScriptContext ctx' <- tcont $ pmatch ctx + ctx'' <- tcont $ pletFields @'["txInfo", "purpose"] ctx' + PTxInfo txInfo <- tcont $ pmatch $ pfromData (hrecField @"txInfo" ctx'') + txInfo' <- tcont $ pletFields @'["signatories", "outputs"] txInfo + let outputs = hrecField @"outputs" txInfo' + + assert "Created stake must be owned by a signer of this transaction" $ + pany + # ( plam $ \txOut -> unTermCont $ do + PTxOut txOut' <- tcont $ pmatch (pfromData txOut) + _txOut'' <- tcont $ pletFields @'["value", "datumHash"] txOut' + pure (pcon PTrue) + ) + # outputs + + pure (pcon PUnit) diff --git a/src/Agora/Voting.hs b/src/Agora/Voting.hs new file mode 100644 index 0000000..74354a5 --- /dev/null +++ b/src/Agora/Voting.hs @@ -0,0 +1,4 @@ +-- | Types for votes and vote counting +module Agora.Voting (Vote (..)) where + +data Vote = InFavorOf | OpposedTo