From c5e17dddeb471b357965201c57a0ba6f9228e425 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Mon, 7 Feb 2022 22:45:09 +0100 Subject: [PATCH 01/15] safe-money proof of concept --- agora.cabal | 5 +- src/Agora/AuthorityToken.hs | 44 +---------- src/Agora/SafeMoney.hs | 143 ++++++++++++++++++++++++++++++++++++ src/Agora/SafeMoney/QQ.hs | 88 ++++++++++++++++++++++ 4 files changed, 239 insertions(+), 41 deletions(-) create mode 100644 src/Agora/SafeMoney.hs create mode 100644 src/Agora/SafeMoney/QQ.hs diff --git a/agora.cabal b/agora.cabal index bc8e01d..6e40499 100644 --- a/agora.cabal +++ b/agora.cabal @@ -92,7 +92,10 @@ common test-deps library import: lang, deps - exposed-modules: Agora.AuthorityToken + exposed-modules: + Agora.AuthorityToken + Agora.SafeMoney + Agora.SafeMoney.QQ other-modules: hs-source-dirs: src diff --git a/src/Agora/AuthorityToken.hs b/src/Agora/AuthorityToken.hs index bbd2849..c51f8e6 100644 --- a/src/Agora/AuthorityToken.hs +++ b/src/Agora/AuthorityToken.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PolyKinds #-} + module Agora.AuthorityToken ( authorityTokenPolicy, AuthorityToken (..), @@ -16,6 +18,8 @@ import Plutarch.Api.V1 import Plutarch.List (pfoldr') import Plutarch.Prelude +import Agora.SafeMoney + -------------------------------------------------------------------------------- {- | An AuthorityToken represents a proof that a particular token @@ -31,46 +35,6 @@ data AuthorityToken = AuthorityToken -------------------------------------------------------------------------------- --- TODO: upstream something like this -pfind' :: - PIsListLike list a => - (Term s a -> Term s PBool) -> - Term s (list a :--> PMaybe a) -pfind' p = - precList - (\self x xs -> pif (p x) (pcon (PJust x)) (self # xs)) - (const $ pcon PNothing) - --- TODO: upstream something like this -plookup :: - (PEq a, PIsListLike list (PBuiltinPair a b)) => - Term s (a :--> list (PBuiltinPair a b) :--> PMaybe b) -plookup = - phoistAcyclic $ - plam $ \k xs -> - pmatch (pfind' (\p -> pfstBuiltin # p #== k) # xs) $ \case - PNothing -> pcon PNothing - PJust p -> pcon (PJust (psndBuiltin # p)) - -passetClassValueOf' :: AssetClass -> Term s (PValue :--> PInteger) -passetClassValueOf' (AssetClass (sym, token)) = - passetClassValueOf # pconstant sym # pconstant token - -passetClassValueOf :: - Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PInteger) -passetClassValueOf = - phoistAcyclic $ - plam $ \sym token value'' -> - pmatch value'' $ \(PValue value') -> - pmatch value' $ \(PMap value) -> - pmatch (plookup # pdata sym # value) $ \case - PNothing -> 0 - PJust m' -> - pmatch (pfromData m') $ \(PMap m) -> - pmatch (plookup # pdata token # m) $ \case - PNothing -> 0 - PJust v -> pfromData v - authorityTokenPolicy :: AuthorityToken -> Term s (PData :--> PData :--> PScriptContext :--> PUnit) diff --git a/src/Agora/SafeMoney.hs b/src/Agora/SafeMoney.hs new file mode 100644 index 0000000..f4107fb --- /dev/null +++ b/src/Agora/SafeMoney.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# OPTIONS_GHC -Wwarn=missing-methods #-} +{-# OPTIONS_GHC -Wwarn=unused-imports #-} + +module Agora.SafeMoney (module Agora.SafeMoney) where + +import Data.Proxy (Proxy (Proxy)) +import Data.String +import GHC.TypeLits ( + CmpNat, + KnownNat, + KnownSymbol, + Nat, + SomeNat (..), + SomeSymbol (..), + Symbol, + natVal, + someNatVal, + someSymbolVal, + symbolVal, + ) +import Prelude + +-------------------------------------------------------------------------------- + +import Plutus.V1.Ledger.Value (AssetClass (..)) +import Plutus.V1.Ledger.Value qualified as Ledger + +-------------------------------------------------------------------------------- + +import Plutarch.Api.V1 +import Plutarch.Internal +import Plutarch.Prelude + +-------------------------------------------------------------------------------- + +-- | Type-level unique identifier for an AssetClass +type MoneyClass = + ( -- AssetClass + Symbol + , -- TokenName + Symbol + , -- Decimal places + Nat + ) + +newtype Discrete (mc :: MoneyClass) (s :: S) + = Discrete (Term s PInteger) + deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype (Discrete mc) PInteger) + +instance Num (Term s (Discrete mc)) where + (+) x y = pcon $ + Discrete . unTermCont $ do + Discrete x' <- tcont $ pmatch x + Discrete y' <- tcont $ pmatch y + pure (x' + y') + abs x = pcon $ + Discrete . unTermCont $ do + Discrete x' <- tcont $ pmatch x + pure (abs x') + negate x = pcon $ + Discrete . unTermCont $ do + Discrete x' <- tcont $ pmatch x + pure (negate x') + (*) x y = pcon $ + Discrete . unTermCont $ do + Discrete x' <- tcont $ pmatch x + Discrete y' <- tcont $ pmatch y + pure (x' * y') + fromInteger = error "Tried to `fromInteger` for a Discrete type. use `discrete` quasiquoter instead." + +(^*) :: Term s (Discrete mc) -> Term s PInteger -> Term s (Discrete mc) +(^*) x y = pcon $ + Discrete . unTermCont $ do + Discrete x' <- tcont $ pmatch x + pure (x' * y) + +type LQ :: MoneyClass +type LQ = '("da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24", "LQ", 6) + +type ADA :: MoneyClass +type ADA = '("", "", 6) + +-------------------------------------------------------------------------------- + +-- TODO: upstream something like this +pfind' :: + PIsListLike list a => + (Term s a -> Term s PBool) -> + Term s (list a :--> PMaybe a) +pfind' p = + precList + (\self x xs -> pif (p x) (pcon (PJust x)) (self # xs)) + (const $ pcon PNothing) + +-- TODO: upstream something like this +plookup :: + (PEq a, PIsListLike list (PBuiltinPair a b)) => + Term s (a :--> list (PBuiltinPair a b) :--> PMaybe b) +plookup = + phoistAcyclic $ + plam $ \k xs -> + pmatch (pfind' (\p -> pfstBuiltin # p #== k) # xs) $ \case + PNothing -> pcon PNothing + PJust p -> pcon (PJust (psndBuiltin # p)) + +matchMaybe :: Term s r -> Term s (PMaybe a) -> TermCont @r s (Term s a) +matchMaybe r f = TermCont $ \k -> + pmatch f $ \case + PJust v -> k v + PNothing -> r + +passetClassValueOf :: + Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PInteger) +passetClassValueOf = + phoistAcyclic $ + plam $ \sym token value'' -> unTermCont $ do + PValue value' <- tcont $ pmatch value'' + PMap value <- tcont $ pmatch value' + m' <- matchMaybe 0 (plookup # pdata sym # value) + PMap m <- tcont (pmatch (pfromData m')) + v <- matchMaybe 0 (plookup # pdata token # m) + pure (pfromData v) + +passetClassValueOf' :: AssetClass -> Term s (PValue :--> PInteger) +passetClassValueOf' (AssetClass (sym, token)) = + passetClassValueOf # pconstant sym # pconstant token + +-- | Downcast a 'PValue' to a 'Discrete' unit +valueDiscrete :: + forall (moneyClass :: MoneyClass) (ac :: Symbol) (n :: Symbol) (scale :: Nat) s. + ( KnownSymbol ac + , KnownSymbol n + , moneyClass ~ '(ac, n, scale) + ) => + Term s (PValue :--> Discrete moneyClass) +valueDiscrete = phoistAcyclic $ + plam $ \f -> + pcon . Discrete $ + passetClassValueOf # (pconstant $ fromString $ symbolVal $ Proxy @ac) + # (pconstant $ fromString $ symbolVal $ Proxy @n) + # f diff --git a/src/Agora/SafeMoney/QQ.hs b/src/Agora/SafeMoney/QQ.hs new file mode 100644 index 0000000..29a5213 --- /dev/null +++ b/src/Agora/SafeMoney/QQ.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wwarn=missing-methods #-} +{-# OPTIONS_GHC -Wwarn=unused-imports #-} + +module Agora.SafeMoney.QQ (discrete) where + +import Control.Arrow ((&&&)) +import Data.Ratio (denominator, numerator) +import Debug.Trace +import GHC.Real (Ratio ((:%))) +import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter)) +import Language.Haskell.TH.Syntax ( + Dec (TySynD), + Exp (AppE, AppTypeE, LitE, VarE), + Info (TyConI), + Lit (IntegerL), + Pat, + Q, + TyLit (NumTyLit, StrTyLit), + Type (AppT, ConT, LitT, PromotedTupleT), + lookupTypeName, + reify, + reifyType, + ) +import PlutusTx.Ratio (unsafeRatio) +import Text.ParserCombinators.ReadP (readP_to_S, skipSpaces) +import Text.Read (lexP, readMaybe, readPrec_to_P) +import Text.Read.Lex (Lexeme (Ident, Number), Number, numberToFixed, numberToRational) +import Prelude + +-------------------------------------------------------------------------------- + +import Plutarch.Internal (punsafeCoerce) +import Plutarch.Prelude hiding (Type) + +import Agora.SafeMoney + +discrete :: QuasiQuoter +discrete = QuasiQuoter discreteExp errorDiscretePat errorDiscreteType errorDiscreteDiscretelaration + +discreteConstant :: forall (moneyClass :: MoneyClass) s. Integer -> Term s (Discrete moneyClass) +discreteConstant n = punsafeCoerce ((pconstant n) :: Term s PInteger) + +fixedToInteger :: Integer -> (Integer, Integer) -> Integer +fixedToInteger places (i, f) = i * 10 ^ places + f + +safeIntegerUpcast :: Integer -> Number -> Either String Integer +safeIntegerUpcast places num = + case (numberToFixed places num, numberToRational num * 10 ^ places) of + (Just (i, f), _n :% 1) -> + Right $ fixedToInteger places (i, f) + (Just (i, f), _n :% _d) -> + Left $ "Using more than the available decimal places (" <> show places <> "). Would round to " <> show i <> "." <> show f + _ -> Left "Some error occurred while getting number" + +discreteExp :: String -> Q Exp +discreteExp s = case parseDiscreteRatioExp s of + Nothing -> + fail $ "Input malformed. Got: " <> s + Just (num, mc) -> do + mcName <- + lookupTypeName mc >>= \case + Nothing -> fail $ "MoneyClass with the name " <> show mc <> " is not in scope." + Just v -> pure v + reified <- reify mcName + case reified of + TyConI (TySynD tyName [] (AppT (AppT (AppT (PromotedTupleT 3) (LitT (StrTyLit _))) (LitT _)) (LitT (NumTyLit n)))) -> + case safeIntegerUpcast n num of + Right i -> + pure $ AppE (AppTypeE (VarE 'discreteConstant) (ConT tyName)) (LitE (IntegerL i)) + Left e -> fail e + ty' -> fail $ "Could not reify type, got: " <> show ty' + +parseDiscreteRatioExp :: String -> Maybe (Number, String) +parseDiscreteRatioExp s = + let p = skipSpaces *> ((,) <$> readPrec_to_P lexP 0 <* skipSpaces <*> readPrec_to_P lexP 0) <* skipSpaces + in case readP_to_S p s of + [((Number n, Ident i), "")] -> Just (n, i) + _ -> Nothing + +errorDiscretePat :: String -> Q Pat +errorDiscretePat _ = fail "Cannot use 'discrete' in a pattern context." + +errorDiscreteType :: String -> Q Type +errorDiscreteType _ = fail "Cannot use 'discrete' in a type context." + +errorDiscreteDiscretelaration :: String -> Q [Dec] +errorDiscreteDiscretelaration _ = fail "Cannot use 'discrete' in a declaration context." From 4d8d5bb4b171bbb518847de6a84482c7f17d4e10 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Tue, 15 Feb 2022 23:08:10 +0100 Subject: [PATCH 02/15] WIP Stake policy --- agora.cabal | 3 ++ flake.lock | 9 ++-- flake.nix | 2 +- src/Agora/AuthorityToken.hs | 4 +- src/Agora/Stake.hs | 94 +++++++++++++++++++++++++++++++++++++ src/Agora/Voting.hs | 4 ++ 6 files changed, 108 insertions(+), 8 deletions(-) create mode 100644 src/Agora/Stake.hs create mode 100644 src/Agora/Voting.hs 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 From 1fb592c6ce09a53e516c1fb906a5c0ba2c7f0112 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Wed, 16 Feb 2022 21:12:32 +0100 Subject: [PATCH 03/15] use Plutarch.Monadic in Stake --- src/Agora/Stake.hs | 32 ++++++++++++++------------------ 1 file changed, 14 insertions(+), 18 deletions(-) diff --git a/src/Agora/Stake.hs b/src/Agora/Stake.hs index 21ab7af..a5519a3 100644 --- a/src/Agora/Stake.hs +++ b/src/Agora/Stake.hs @@ -23,6 +23,7 @@ import Plutarch.DataRepr ( PIsDataReprInstances (PIsDataReprInstances), ) import Plutarch.Internal +import Plutarch.Monadic qualified as P -------------------------------------------------------------------------------- @@ -62,33 +63,28 @@ newtype StakeDatum (gt :: MoneyClass) (s :: S) = StakeDatum (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) +passert :: Term s PString -> Term s PBool -> Term s k -> Term s k +passert errorMessage check k = pif check k (ptraceError errorMessage) 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 + plam $ \_redeemer ctx -> P.do + PScriptContext ctx' <- pmatch ctx + ctx'' <- pletFields @'["txInfo", "purpose"] ctx' + PTxInfo txInfo <- pmatch $ pfromData (hrecField @"txInfo" ctx'') + txInfo' <- pletFields @'["signatories", "outputs"] txInfo let outputs = hrecField @"outputs" txInfo' - assert "Created stake must be owned by a signer of this transaction" $ + passert "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) + # ( plam $ \txOut -> P.do + PTxOut txOut' <- pmatch (pfromData txOut) + _txOut'' <- pletFields @'["value", "datumHash"] txOut' + pcon PTrue ) # outputs - pure (pcon PUnit) + pcon PUnit From b834b4ebad576b79d3f2e07caad326d0899c3bea Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Thu, 17 Feb 2022 20:52:35 +0100 Subject: [PATCH 04/15] correctly check output datum and value --- src/Agora/SafeMoney.hs | 39 ++++++++++++++++++++ src/Agora/Stake.hs | 81 +++++++++++++++++++++++++++++++++--------- 2 files changed, 104 insertions(+), 16 deletions(-) diff --git a/src/Agora/SafeMoney.hs b/src/Agora/SafeMoney.hs index daa9553..1f8faa4 100644 --- a/src/Agora/SafeMoney.hs +++ b/src/Agora/SafeMoney.hs @@ -31,6 +31,7 @@ import Plutus.V1.Ledger.Value qualified as Ledger -------------------------------------------------------------------------------- import Plutarch.Api.V1 +import Plutarch.Builtin import Plutarch.Internal import Plutarch.Prelude @@ -106,6 +107,17 @@ plookup = PNothing -> pcon PNothing PJust p -> pcon (PJust (psndBuiltin # p)) +-- This is quite silly. +plookupTuple :: + (PEq a, PIsListLike list (PAsData (PTuple a b)), PIsData a, PIsData b) => + Term s (a :--> list (PAsData (PTuple a b)) :--> PMaybe b) +plookupTuple = + phoistAcyclic $ + plam $ \k xs -> + pmatch (pfind' (\p -> (pfield @"_0" # pfromData p) #== k) # xs) $ \case + PNothing -> pcon PNothing + PJust p -> pcon (PJust (pfield @"_1" # pfromData p)) + matchMaybe :: Term s r -> Term s (PMaybe a) -> TermCont @r s (Term s a) matchMaybe r f = TermCont $ \k -> pmatch f $ \case @@ -142,3 +154,30 @@ valueDiscrete = phoistAcyclic $ passetClassValueOf # (pconstant $ fromString $ symbolVal $ Proxy @ac) # (pconstant $ fromString $ symbolVal $ Proxy @n) # f + +-- NOTE: discreteValue after valueDiscrete is loses information + +-- | Get a 'PValue' from a 'Discrete' +discreteValue :: + forall (moneyClass :: MoneyClass) (ac :: Symbol) (n :: Symbol) (scale :: Nat) s. + ( KnownSymbol ac + , KnownSymbol n + , moneyClass ~ '(ac, n, scale) + ) => + Term s (Discrete moneyClass :--> PValue) +discreteValue = phoistAcyclic $ + plam $ \f -> pmatch f $ \case + Discrete p -> + psingletonValue + # (pconstant $ fromString $ symbolVal $ Proxy @ac) + # (pconstant $ fromString $ symbolVal $ Proxy @n) + # p + +-- | Create a value with a single asset class +psingletonValue :: forall s. Term s (PCurrencySymbol :--> PTokenName :--> PInteger :--> PValue) +psingletonValue = phoistAcyclic $ + plam $ \sym tok int -> + let innerTup = pcon $ PMap $ psingleton #$ ppairDataBuiltin # pdata tok # pdata int + outerTup = pcon $ PMap $ psingleton #$ ppairDataBuiltin # pdata sym # pdata innerTup + res = pcon $ PValue outerTup + in res diff --git a/src/Agora/Stake.hs b/src/Agora/Stake.hs index a5519a3..34d7230 100644 --- a/src/Agora/Stake.hs +++ b/src/Agora/Stake.hs @@ -12,6 +12,9 @@ module Agora.Stake ( -------------------------------------------------------------------------------- import GHC.Generics qualified as GHC +import GHC.TypeLits ( + KnownSymbol, + ) import Generics.SOP (Generic, I (I)) import Prelude @@ -63,28 +66,74 @@ newtype StakeDatum (gt :: MoneyClass) (s :: S) = StakeDatum (PlutusType, PIsData, PDataFields) via (PIsDataReprInstances (StakeDatum gt)) +-- | Assert a particular bool, trace on falsehood. Use in monadic context passert :: Term s PString -> Term s PBool -> Term s k -> Term s k passert errorMessage check k = pif check k (ptraceError errorMessage) +-- | Find a datum with the given hash. +pfindDatum :: Term s (PDatumHash :--> PTxInfo :--> PMaybe PDatum) +pfindDatum = phoistAcyclic $ + plam $ \datumHash txInfo'' -> P.do + PTxInfo txInfo' <- pmatch txInfo'' + plookupTuple # datumHash #$ pfield @"data" # txInfo' + +-- | Find a datum with the given hash. NOTE: this is unsafe in the sense that, if the data layout is wrong, this is UB. +pfindDatum' :: PIsData a => Term s (PDatumHash :--> PTxInfo :--> PMaybe (PAsData a)) +pfindDatum' = phoistAcyclic $ plam $ \dh x -> punsafeCoerce $ pfindDatum # dh # x + +-- | Check if a PubKeyHash signs this transaction +ptxSignedBy :: Term s (PTxInfo :--> PAsData PPubKeyHash :--> PBool) +ptxSignedBy = phoistAcyclic $ + plam $ \txInfo' pkh -> P.do + txInfo <- pletFields @'["signatories"] txInfo' + pelem @PBuiltinList # pkh # txInfo.signatories + +-- | Check if any output matches the predicate +anyOutput :: + forall (datum :: PType) s. + ( PIsData datum + ) => + Term s (PTxInfo :--> (PValue :--> datum :--> PBool) :--> PBool) +anyOutput = phoistAcyclic $ + plam $ \txInfo' predicate -> P.do + txInfo <- pletFields @'["outputs"] txInfo' + pany + # ( plam $ \txOut'' -> P.do + PTxOut txOut' <- pmatch (pfromData txOut'') + txOut <- pletFields @'["value", "datumHash"] txOut' + PDJust dh <- pmatch txOut.datumHash + pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case + PJust datum -> P.do + predicate # txOut.value # pfromData datum + PNothing -> pcon PFalse + ) + # pfromData txInfo.outputs + stakePolicy :: - forall (gt :: MoneyClass) s. - Stake gt -> + forall (gt :: MoneyClass) ac n scale s. + ( KnownSymbol ac + , KnownSymbol n + , gt ~ '(ac, n, scale) + ) => + Stake + gt -> Term s (PData :--> PScriptContext :--> PUnit) stakePolicy _stake = - plam $ \_redeemer ctx -> P.do - PScriptContext ctx' <- pmatch ctx - ctx'' <- pletFields @'["txInfo", "purpose"] ctx' - PTxInfo txInfo <- pmatch $ pfromData (hrecField @"txInfo" ctx'') - txInfo' <- pletFields @'["signatories", "outputs"] txInfo - let outputs = hrecField @"outputs" txInfo' + plam $ \_redeemer ctx'' -> P.do + PScriptContext ctx' <- pmatch ctx'' + ctx <- pletFields @'["txInfo", "purpose"] ctx' - passert "Created stake must be owned by a signer of this transaction" $ - pany - # ( plam $ \txOut -> P.do - PTxOut txOut' <- pmatch (pfromData txOut) - _txOut'' <- pletFields @'["value", "datumHash"] txOut' - pcon PTrue + PMinting ownSymbol <- pmatch $ pfromData ctx.purpose + -- TODO: add this to 'valueCorrect' + let _stValue = psingletonValue # (pfield @"_0" # ownSymbol) # pconstant "ST" # 1 + + passert "A UTXO must exist with the correct output" $ + anyOutput @(StakeDatum gt) # pfromData ctx.txInfo + # ( plam $ \value stakeDatum' -> P.do + stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum' + let ownerSignsTransaction = ptxSignedBy # ctx.txInfo # stakeDatum.owner + let valueCorrect = pdata value #== pdata (discreteValue # stakeDatum.stakedAmount) + ownerSignsTransaction #&& valueCorrect ) - # outputs - pcon PUnit + pconstant () From 99af5e26fac8307213bfdf7b27f5c27b45402a94 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Fri, 18 Feb 2022 17:21:05 +0100 Subject: [PATCH 05/15] add Utils module, fix stake policy missing ST --- agora.cabal | 1 + src/Agora/AuthorityToken.hs | 2 +- src/Agora/SafeMoney.hs | 58 +------------- src/Agora/Stake.hs | 27 +------ src/Agora/Utils.hs | 151 ++++++++++++++++++++++++++++++++++++ 5 files changed, 160 insertions(+), 79 deletions(-) create mode 100644 src/Agora/Utils.hs diff --git a/agora.cabal b/agora.cabal index c874b3f..5f8ded4 100644 --- a/agora.cabal +++ b/agora.cabal @@ -121,6 +121,7 @@ library Agora.Voting other-modules: + Agora.Utils hs-source-dirs: src library pprelude diff --git a/src/Agora/AuthorityToken.hs b/src/Agora/AuthorityToken.hs index 0734987..e32906e 100644 --- a/src/Agora/AuthorityToken.hs +++ b/src/Agora/AuthorityToken.hs @@ -20,7 +20,7 @@ import Prelude -------------------------------------------------------------------------------- -import Agora.SafeMoney +import Agora.Utils (passetClassValueOf, passetClassValueOf') -------------------------------------------------------------------------------- diff --git a/src/Agora/SafeMoney.hs b/src/Agora/SafeMoney.hs index 1f8faa4..f7abcaf 100644 --- a/src/Agora/SafeMoney.hs +++ b/src/Agora/SafeMoney.hs @@ -37,6 +37,10 @@ import Plutarch.Prelude -------------------------------------------------------------------------------- +import Agora.Utils + +-------------------------------------------------------------------------------- + -- | Type-level unique identifier for an AssetClass type MoneyClass = ( -- AssetClass @@ -86,60 +90,6 @@ type ADA = '("", "", 6) -------------------------------------------------------------------------------- --- TODO: upstream something like this -pfind' :: - PIsListLike list a => - (Term s a -> Term s PBool) -> - Term s (list a :--> PMaybe a) -pfind' p = - precList - (\self x xs -> pif (p x) (pcon (PJust x)) (self # xs)) - (const $ pcon PNothing) - --- TODO: upstream something like this -plookup :: - (PEq a, PIsListLike list (PBuiltinPair a b)) => - Term s (a :--> list (PBuiltinPair a b) :--> PMaybe b) -plookup = - phoistAcyclic $ - plam $ \k xs -> - pmatch (pfind' (\p -> pfstBuiltin # p #== k) # xs) $ \case - PNothing -> pcon PNothing - PJust p -> pcon (PJust (psndBuiltin # p)) - --- This is quite silly. -plookupTuple :: - (PEq a, PIsListLike list (PAsData (PTuple a b)), PIsData a, PIsData b) => - Term s (a :--> list (PAsData (PTuple a b)) :--> PMaybe b) -plookupTuple = - phoistAcyclic $ - plam $ \k xs -> - pmatch (pfind' (\p -> (pfield @"_0" # pfromData p) #== k) # xs) $ \case - PNothing -> pcon PNothing - PJust p -> pcon (PJust (pfield @"_1" # pfromData p)) - -matchMaybe :: Term s r -> Term s (PMaybe a) -> TermCont @r s (Term s a) -matchMaybe r f = TermCont $ \k -> - pmatch f $ \case - PJust v -> k v - PNothing -> r - -passetClassValueOf :: - Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PInteger) -passetClassValueOf = - phoistAcyclic $ - plam $ \sym token value'' -> unTermCont $ do - PValue value' <- tcont $ pmatch value'' - PMap value <- tcont $ pmatch value' - m' <- matchMaybe 0 (plookup # pdata sym # value) - PMap m <- tcont (pmatch (pfromData m')) - v <- matchMaybe 0 (plookup # pdata token # m) - pure (pfromData v) - -passetClassValueOf' :: AssetClass -> Term s (PValue :--> PInteger) -passetClassValueOf' (AssetClass (sym, token)) = - passetClassValueOf # pconstant sym # pconstant token - -- | Downcast a 'PValue' to a 'Discrete' unit valueDiscrete :: forall (moneyClass :: MoneyClass) (ac :: Symbol) (n :: Symbol) (scale :: Nat) s. diff --git a/src/Agora/Stake.hs b/src/Agora/Stake.hs index 34d7230..1e1915c 100644 --- a/src/Agora/Stake.hs +++ b/src/Agora/Stake.hs @@ -31,6 +31,7 @@ import Plutarch.Monadic qualified as P -------------------------------------------------------------------------------- import Agora.SafeMoney +import Agora.Utils -------------------------------------------------------------------------------- @@ -66,28 +67,6 @@ newtype StakeDatum (gt :: MoneyClass) (s :: S) = StakeDatum (PlutusType, PIsData, PDataFields) via (PIsDataReprInstances (StakeDatum gt)) --- | Assert a particular bool, trace on falsehood. Use in monadic context -passert :: Term s PString -> Term s PBool -> Term s k -> Term s k -passert errorMessage check k = pif check k (ptraceError errorMessage) - --- | Find a datum with the given hash. -pfindDatum :: Term s (PDatumHash :--> PTxInfo :--> PMaybe PDatum) -pfindDatum = phoistAcyclic $ - plam $ \datumHash txInfo'' -> P.do - PTxInfo txInfo' <- pmatch txInfo'' - plookupTuple # datumHash #$ pfield @"data" # txInfo' - --- | Find a datum with the given hash. NOTE: this is unsafe in the sense that, if the data layout is wrong, this is UB. -pfindDatum' :: PIsData a => Term s (PDatumHash :--> PTxInfo :--> PMaybe (PAsData a)) -pfindDatum' = phoistAcyclic $ plam $ \dh x -> punsafeCoerce $ pfindDatum # dh # x - --- | Check if a PubKeyHash signs this transaction -ptxSignedBy :: Term s (PTxInfo :--> PAsData PPubKeyHash :--> PBool) -ptxSignedBy = phoistAcyclic $ - plam $ \txInfo' pkh -> P.do - txInfo <- pletFields @'["signatories"] txInfo' - pelem @PBuiltinList # pkh # txInfo.signatories - -- | Check if any output matches the predicate anyOutput :: forall (datum :: PType) s. @@ -125,14 +104,14 @@ stakePolicy _stake = PMinting ownSymbol <- pmatch $ pfromData ctx.purpose -- TODO: add this to 'valueCorrect' - let _stValue = psingletonValue # (pfield @"_0" # ownSymbol) # pconstant "ST" # 1 + let stValue = psingletonValue # (pfield @"_0" # ownSymbol) # pconstant "ST" # 1 passert "A UTXO must exist with the correct output" $ anyOutput @(StakeDatum gt) # pfromData ctx.txInfo # ( plam $ \value stakeDatum' -> P.do stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum' let ownerSignsTransaction = ptxSignedBy # ctx.txInfo # stakeDatum.owner - let valueCorrect = pdata value #== pdata (discreteValue # stakeDatum.stakedAmount) + let valueCorrect = pdata value #== pdata (paddValue # (discreteValue # stakeDatum.stakedAmount) # stValue) ownerSignsTransaction #&& valueCorrect ) diff --git a/src/Agora/Utils.hs b/src/Agora/Utils.hs new file mode 100644 index 0000000..dde004e --- /dev/null +++ b/src/Agora/Utils.hs @@ -0,0 +1,151 @@ +-- | Plutarch utility functions that should be upstreamed or don't belong anywhere else +module Agora.Utils (module Agora.Utils) where + +-------------------------------------------------------------------------------- + +import Plutus.V1.Ledger.Value (AssetClass (..)) + +-------------------------------------------------------------------------------- + +import Plutarch.Api.V1 ( + PCurrencySymbol, + PDatum, + PDatumHash, + PMap (PMap), + PPubKeyHash, + PTokenName, + PTuple, + PTxInfo (PTxInfo), + PValue (PValue), + ) +import Plutarch.Builtin (ppairDataBuiltin) +import Plutarch.Internal (punsafeCoerce) +import Plutarch.Monadic qualified as P + +-------------------------------------------------------------------------------- + +-- | Assert a particular bool, trace on falsehood. Use in monadic context +passert :: Term s PString -> Term s PBool -> Term s k -> Term s k +passert errorMessage check k = pif check k (ptraceError errorMessage) + +-- | Find a datum with the given hash. +pfindDatum :: Term s (PDatumHash :--> PTxInfo :--> PMaybe PDatum) +pfindDatum = phoistAcyclic $ + plam $ \datumHash txInfo'' -> P.do + PTxInfo txInfo' <- pmatch txInfo'' + plookupTuple # datumHash #$ pfield @"data" # txInfo' + +-- | Find a datum with the given hash. NOTE: this is unsafe in the sense that, if the data layout is wrong, this is UB. +pfindDatum' :: PIsData a => Term s (PDatumHash :--> PTxInfo :--> PMaybe (PAsData a)) +pfindDatum' = phoistAcyclic $ plam $ \dh x -> punsafeCoerce $ pfindDatum # dh # x + +-- | Check if a PubKeyHash signs this transaction +ptxSignedBy :: Term s (PTxInfo :--> PAsData PPubKeyHash :--> PBool) +ptxSignedBy = phoistAcyclic $ + plam $ \txInfo' pkh -> P.do + txInfo <- pletFields @'["signatories"] txInfo' + pelem @PBuiltinList # pkh # txInfo.signatories + +-- | Get the first element that matches a predicate or return Nothing +pfind' :: + PIsListLike list a => + (Term s a -> Term s PBool) -> + Term s (list a :--> PMaybe a) +pfind' p = + precList + (\self x xs -> pif (p x) (pcon (PJust x)) (self # xs)) + (const $ pcon PNothing) + +-- | Find the value for a given key in an assoclist +plookup :: + (PEq a, PIsListLike list (PBuiltinPair a b)) => + Term s (a :--> list (PBuiltinPair a b) :--> PMaybe b) +plookup = + phoistAcyclic $ + plam $ \k xs -> + pmatch (pfind' (\p -> pfstBuiltin # p #== k) # xs) $ \case + PNothing -> pcon PNothing + PJust p -> pcon (PJust (psndBuiltin # p)) + +-- | Find the value for a given key in an assoclist which uses 'PTuple's +plookupTuple :: + (PEq a, PIsListLike list (PAsData (PTuple a b)), PIsData a, PIsData b) => + Term s (a :--> list (PAsData (PTuple a b)) :--> PMaybe b) +plookupTuple = + phoistAcyclic $ + plam $ \k xs -> + pmatch (pfind' (\p -> (pfield @"_0" # pfromData p) #== k) # xs) $ \case + PNothing -> pcon PNothing + PJust p -> pcon (PJust (pfield @"_1" # pfromData p)) + +-- | Extract a Maybe by providing a default value in case of Just +pfromMaybe :: forall a s. Term s (a :--> PMaybe a :--> a) +pfromMaybe = phoistAcyclic $ + plam $ \e a -> + pmatch a $ \case + PJust a' -> a' + PNothing -> e + +-- | Escape with a particular value on expecting 'Just'. For use in monadic context +pexpectJust :: forall r a s. Term s r -> Term s (PMaybe a) -> (Term s a -> Term s r) -> Term s r +pexpectJust escape ma f = + pmatch ma $ \case + PJust v -> f v + PNothing -> escape + +passetClassValueOf :: + Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PInteger) +passetClassValueOf = + phoistAcyclic $ + plam $ \sym token value'' -> P.do + PValue value' <- pmatch value'' + PMap value <- pmatch value' + m' <- pexpectJust 0 (plookup # pdata sym # value) + PMap m <- pmatch (pfromData m') + v <- pexpectJust 0 (plookup # pdata token # m) + pfromData v + +passetClassValueOf' :: AssetClass -> Term s (PValue :--> PInteger) +passetClassValueOf' (AssetClass (sym, token)) = + passetClassValueOf # pconstant sym # pconstant token + +-- | Union two maps using a merge function on collisions +pmapUnionWith :: forall k v s. PIsData v => Term s ((v :--> v :--> v) :--> PMap k v :--> PMap k v :--> PMap k v) +pmapUnionWith = phoistAcyclic $ + -- TODO: this function is kinda suspect. I feel like a lot of optimizations could be done here + plam $ \f xs' ys' -> P.do + PMap xs <- pmatch xs' + PMap ys <- pmatch ys' + let ls = + pmap + # ( plam $ \p -> P.do + pf <- plet $ pfstBuiltin # p + ps <- plet $ psndBuiltin # p + pmatch (plookup # pf # ys) $ \case + PJust v -> P.do + -- Data conversions here are silly, aren't they? + ppairDataBuiltin # pf # (pdata (f # pfromData ps # pfromData v)) + PNothing -> p + ) + # xs + rs = + pfilter + # ( plam $ \p -> + pnot # (pany # (plam $ \p' -> pfstBuiltin # p' #== pfstBuiltin # p) # xs) + ) + # ys + pcon (PMap $ pconcat # ls # rs) + +-- | Add two 'PValue's together +paddValue :: forall s. Term s (PValue :--> PValue :--> PValue) +paddValue = phoistAcyclic $ + plam $ \a' b' -> P.do + PValue a <- pmatch a' + PValue b <- pmatch b' + pcon + ( PValue $ + pmapUnionWith + # (plam $ \a' b' -> pmapUnionWith # (plam (+)) # a' # b') + # a + # b + ) From eb4b9d8b1e47dc13d8a3e8286b2bb2b08b96f2f3 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Fri, 18 Feb 2022 20:52:06 +0100 Subject: [PATCH 06/15] bump plutarch --- flake.lock | 8 +++----- src/Agora/Utils.hs | 5 +---- 2 files changed, 4 insertions(+), 9 deletions(-) diff --git a/flake.lock b/flake.lock index e68b47a..6247424 100644 --- a/flake.lock +++ b/flake.lock @@ -440,8 +440,6 @@ "hpc-coveralls": "hpc-coveralls", "nix-tools": "nix-tools", "nixpkgs": [ - "plutarch", - "haskell-nix", "nixpkgs-2111" ], "nixpkgs-2003": "nixpkgs-2003", @@ -832,11 +830,11 @@ "validity": "validity" }, "locked": { - "lastModified": 1645006916, - "narHash": "sha256-j8o0D48LfDYqf07bi34474lkFnMZ5TNvcZmACVMw3yA=", + "lastModified": 1645200363, + "narHash": "sha256-k/ecf2uasWwBV+zq3daJVGY3xnsYkLe3zmT+k+iZ++A=", "owner": "Plutonomicon", "repo": "plutarch", - "rev": "c77fcd605269bd8183d5496e297eb38503ea0e29", + "rev": "473424c89b4457e58e009e65d411ace1efc3ea9e", "type": "github" }, "original": { diff --git a/src/Agora/Utils.hs b/src/Agora/Utils.hs index dde004e..7a81cd8 100644 --- a/src/Agora/Utils.hs +++ b/src/Agora/Utils.hs @@ -144,8 +144,5 @@ paddValue = phoistAcyclic $ PValue b <- pmatch b' pcon ( PValue $ - pmapUnionWith - # (plam $ \a' b' -> pmapUnionWith # (plam (+)) # a' # b') - # a - # b + pmapUnionWith # (plam $ \a' b' -> pmapUnionWith # (plam (+)) # a' # b') # a # b ) From b905d86d88baf542d3d90ea9c02bbabccd5023af Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Fri, 18 Feb 2022 23:05:55 +0100 Subject: [PATCH 07/15] add missing asserts to Stake policy --- agora.cabal | 5 ++--- bench.csv | 2 +- cabal.project | 3 +++ src/Agora/Stake.hs | 26 +++++++++++++++++++++++--- src/Agora/Utils.hs | 19 +++++++++++++++++++ 5 files changed, 48 insertions(+), 7 deletions(-) diff --git a/agora.cabal b/agora.cabal index 6f1b244..12cd819 100644 --- a/agora.cabal +++ b/agora.cabal @@ -120,8 +120,7 @@ library Agora.Stake Agora.Voting - other-modules: - Agora.Utils + other-modules: Agora.Utils hs-source-dirs: src library pprelude @@ -145,5 +144,5 @@ benchmark agora-bench main-is: Main.hs type: exitcode-stdio-1.0 build-depends: + , agora , plutarch-benchmark - , agora \ No newline at end of file diff --git a/bench.csv b/bench.csv index 867f837..2655634 100644 --- a/bench.csv +++ b/bench.csv @@ -1,3 +1,3 @@ name,cpu,mem,size full_scripts:authorityTokenPolicy,1280339,4400,276 -full_scripts:stakePolicy,2649897,9000,786 +full_scripts:stakePolicy,3007173,10200,937 diff --git a/cabal.project b/cabal.project index ec42141..86a0b28 100644 --- a/cabal.project +++ b/cabal.project @@ -2,3 +2,6 @@ packages: ./. benchmarks: true tests: true + +package plutarch + flags: +development \ No newline at end of file diff --git a/src/Agora/Stake.hs b/src/Agora/Stake.hs index 8e46218..467f6ce 100644 --- a/src/Agora/Stake.hs +++ b/src/Agora/Stake.hs @@ -88,6 +88,17 @@ anyOutput = phoistAcyclic $ ) # pfromData txInfo.outputs +-------------------------------------------------------------------------------- +-- +-- What this Policy does +-- +-- - Check that exactly 1 state thread is minted +-- - Check that an output exists with a state thread and a valid datum +-- - Check that no state thread is an input +-- +-- Question: +-- +-------------------------------------------------------------------------------- stakePolicy :: forall (gt :: MoneyClass) ac n scale s. ( KnownSymbol ac @@ -101,12 +112,21 @@ stakePolicy _stake = plam $ \_redeemer ctx'' -> P.do PScriptContext ctx' <- pmatch ctx'' ctx <- pletFields @'["txInfo", "purpose"] ctx' + txInfo' <- plet ctx.txInfo + txInfo <- pletFields @'["mint", "inputs"] txInfo' - PMinting ownSymbol <- pmatch $ pfromData ctx.purpose - let stValue = psingletonValue # (pfield @"_0" # ownSymbol) # pconstant "ST" # 1 + PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose + ownSymbol <- plet $ pfield @"_0" # ownSymbol' + let stValue = psingletonValue # ownSymbol # pconstant "ST" # 1 + + passert "ST at inputs must be 0" $ + (passetClassValueOf # ownSymbol # pconstant "ST" # (pvalueSpent # pfromData txInfo')) #== 0 + + passert "Minted ST must be exactly 1" $ + pdata txInfo.mint #== pdata stValue passert "A UTXO must exist with the correct output" $ - anyOutput @(StakeDatum gt) # pfromData ctx.txInfo + anyOutput @(StakeDatum gt) # pfromData txInfo' # ( plam $ \value stakeDatum' -> P.do stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum' let expectedValue = paddValue # (discreteValue # stakeDatum.stakedAmount) # stValue diff --git a/src/Agora/Utils.hs b/src/Agora/Utils.hs index 7a81cd8..97e49ba 100644 --- a/src/Agora/Utils.hs +++ b/src/Agora/Utils.hs @@ -15,7 +15,9 @@ import Plutarch.Api.V1 ( PPubKeyHash, PTokenName, PTuple, + PTxInInfo (PTxInInfo), PTxInfo (PTxInfo), + PTxOut (PTxOut), PValue (PValue), ) import Plutarch.Builtin (ppairDataBuiltin) @@ -146,3 +148,20 @@ paddValue = phoistAcyclic $ ( PValue $ pmapUnionWith # (plam $ \a' b' -> pmapUnionWith # (plam (+)) # a' # b') # a # b ) + +-- | Sum of all value at input +pvalueSpent :: Term s (PTxInfo :--> PValue) +pvalueSpent = phoistAcyclic $ + plam $ \txInfo' -> + pmatch txInfo' $ \(PTxInfo txInfo) -> + pfoldr + # ( plam $ \txInInfo' v -> + pmatch + (pfromData txInInfo') + $ \(PTxInInfo txInInfo) -> + paddValue + # (pmatch (pfield @"resolved" # txInInfo) $ \(PTxOut o) -> pfromData $ pfield @"value" # o) + # v + ) + # pconstant mempty + # (pfield @"inputs" # txInfo) From c543310ebf7b8e38344ac1d58a057a86e7b6d052 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Mon, 21 Feb 2022 19:03:05 +0100 Subject: [PATCH 08/15] add burning support to stake policy --- bench.csv | 4 +- src/Agora/Stake.hs | 106 +++++++++++++++++++++++++++++++++++---------- src/Agora/Utils.hs | 1 + 3 files changed, 86 insertions(+), 25 deletions(-) diff --git a/bench.csv b/bench.csv index 2655634..a82edf2 100644 --- a/bench.csv +++ b/bench.csv @@ -1,3 +1,3 @@ name,cpu,mem,size -full_scripts:authorityTokenPolicy,1280339,4400,276 -full_scripts:stakePolicy,3007173,10200,937 +full_scripts:authorityTokenPolicy,1399431,4800,421 +full_scripts:stakePolicy,3662179,12400,1572 diff --git a/src/Agora/Stake.hs b/src/Agora/Stake.hs index 467f6ce..b06d944 100644 --- a/src/Agora/Stake.hs +++ b/src/Agora/Stake.hs @@ -7,6 +7,7 @@ module Agora.Stake ( StakeAction (..), Stake (..), stakePolicy, + stakeLocked, ) where -------------------------------------------------------------------------------- @@ -72,31 +73,59 @@ anyOutput :: forall (datum :: PType) s. ( PIsData datum ) => - Term s (PTxInfo :--> (PValue :--> datum :--> PBool) :--> PBool) + Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool) anyOutput = phoistAcyclic $ plam $ \txInfo' predicate -> P.do txInfo <- pletFields @'["outputs"] txInfo' pany # ( plam $ \txOut'' -> P.do PTxOut txOut' <- pmatch (pfromData txOut'') - txOut <- pletFields @'["value", "datumHash"] txOut' + txOut <- pletFields @'["value", "datumHash", "address"] txOut' PDJust dh <- pmatch txOut.datumHash pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case PJust datum -> P.do - predicate # txOut.value # pfromData datum + predicate # txOut.value # txOut.address # pfromData datum PNothing -> pcon PFalse ) # pfromData txInfo.outputs +anyInput :: + forall (datum :: PType) s. + ( PIsData datum + ) => + Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool) +anyInput = phoistAcyclic $ + plam $ \txInfo' predicate -> P.do + txInfo <- pletFields @'["inputs"] txInfo' + pany + # ( plam $ \txInInfo'' -> P.do + PTxInInfo txInInfo' <- pmatch (pfromData txInInfo'') + let txOut'' = pfield @"resolved" # txInInfo' + PTxOut txOut' <- pmatch (pfromData txOut'') + txOut <- pletFields @'["value", "datumHash", "address"] txOut' + PDJust dh <- pmatch txOut.datumHash + pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case + PJust datum -> P.do + predicate # txOut.value # txOut.address # pfromData datum + PNothing -> pcon PFalse + ) + # pfromData txInfo.inputs + -------------------------------------------------------------------------------- -- --- What this Policy does +-- # What this Policy does -- --- - Check that exactly 1 state thread is minted --- - Check that an output exists with a state thread and a valid datum --- - Check that no state thread is an input +-- For minting: +-- Check that exactly 1 state thread is minted +-- Check that an output exists with a state thread and a valid datum +-- Check that no state thread is an input -- --- Question: +-- FIXME: This doesn't check that it's paid to the right script address, can we? +-- +-- +-- For burning: +-- Check that exactly 1 state thread is burned +-- Check that datum at state thread is valid and not locked -- -------------------------------------------------------------------------------- stakePolicy :: @@ -113,26 +142,57 @@ stakePolicy _stake = PScriptContext ctx' <- pmatch ctx'' ctx <- pletFields @'["txInfo", "purpose"] ctx' txInfo' <- plet ctx.txInfo - txInfo <- pletFields @'["mint", "inputs"] txInfo' + txInfo <- pletFields @'["mint", "inputs", "outputs"] txInfo' PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose ownSymbol <- plet $ pfield @"_0" # ownSymbol' let stValue = psingletonValue # ownSymbol # pconstant "ST" # 1 - passert "ST at inputs must be 0" $ - (passetClassValueOf # ownSymbol # pconstant "ST" # (pvalueSpent # pfromData txInfo')) #== 0 + stOf <- plet $ plam $ \v -> passetClassValueOf # ownSymbol # pconstant "ST" # v + mintedST <- plet $ stOf # txInfo.mint + inputST <- plet $ stOf # (pvalueSpent # pfromData txInfo') - passert "Minted ST must be exactly 1" $ - pdata txInfo.mint #== pdata stValue + let burning = P.do + passert "ST at inputs must be 1" $ + inputST #== 1 - passert "A UTXO must exist with the correct output" $ - anyOutput @(StakeDatum gt) # pfromData txInfo' - # ( plam $ \value stakeDatum' -> P.do - stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum' - let expectedValue = paddValue # (discreteValue # stakeDatum.stakedAmount) # stValue - let ownerSignsTransaction = ptxSignedBy # ctx.txInfo # stakeDatum.owner - let valueCorrect = pdata value #== pdata expectedValue - ownerSignsTransaction #&& valueCorrect - ) + passert "ST burned" $ + mintedST #== -1 - pconstant () + passert "An unlocked input existed containing an ST" $ + anyInput @(StakeDatum gt) # pfromData txInfo' + #$ plam + $ \value _ stakeDatum' -> P.do + let hasST = stOf # value #== 1 + let unlocked = pnot # (stakeLocked # stakeDatum') + hasST #&& unlocked + + pconstant () + + let minting = P.do + passert "ST at inputs must be 0" $ + inputST #== 0 + + passert "Minted ST must be exactly 1" $ + mintedST #== 1 + + passert "A UTXO must exist with the correct output" $ + anyOutput @(StakeDatum gt) # pfromData txInfo' + #$ plam + $ \value _ stakeDatum' -> P.do + stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum' + let expectedValue = paddValue # (discreteValue # stakeDatum.stakedAmount) # stValue + let ownerSignsTransaction = ptxSignedBy # ctx.txInfo # stakeDatum.owner + let valueCorrect = pdata value #== pdata expectedValue -- TODO: Needs to be >=, rather than == + ownerSignsTransaction #&& valueCorrect + + pconstant () + + pif (0 #< mintedST) minting burning + +-- | Check whether a Stake is locked. If it is locked, various actions are unavailable. +stakeLocked :: forall (gt :: MoneyClass) s. Term s (StakeDatum gt :--> PBool) +stakeLocked = phoistAcyclic $ + plam $ \_stakeDatum -> + -- TODO: when we extend this to support proposals, this will need to do something + pcon PFalse diff --git a/src/Agora/Utils.hs b/src/Agora/Utils.hs index 97e49ba..86b10db 100644 --- a/src/Agora/Utils.hs +++ b/src/Agora/Utils.hs @@ -107,6 +107,7 @@ passetClassValueOf = v <- pexpectJust 0 (plookup # pdata token # m) pfromData v +-- | Extract amount from PValue belonging to a Haskell-level AssetClass passetClassValueOf' :: AssetClass -> Term s (PValue :--> PInteger) passetClassValueOf' (AssetClass (sym, token)) = passetClassValueOf # pconstant sym # pconstant token From 6fc34854dbf85d66d3aaac5ec5c9671801f9ca39 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Mon, 21 Feb 2022 21:55:11 +0100 Subject: [PATCH 09/15] check that ST is sent to script --- src/Agora/Stake.hs | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/src/Agora/Stake.hs b/src/Agora/Stake.hs index b06d944..473d785 100644 --- a/src/Agora/Stake.hs +++ b/src/Agora/Stake.hs @@ -89,6 +89,7 @@ anyOutput = phoistAcyclic $ ) # pfromData txInfo.outputs +-- | Check if any (resolved) input matches the predicate anyInput :: forall (datum :: PType) s. ( PIsData datum @@ -179,12 +180,17 @@ stakePolicy _stake = passert "A UTXO must exist with the correct output" $ anyOutput @(StakeDatum gt) # pfromData txInfo' #$ plam - $ \value _ stakeDatum' -> P.do - stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum' - let expectedValue = paddValue # (discreteValue # stakeDatum.stakedAmount) # stValue - let ownerSignsTransaction = ptxSignedBy # ctx.txInfo # stakeDatum.owner - let valueCorrect = pdata value #== pdata expectedValue -- TODO: Needs to be >=, rather than == - ownerSignsTransaction #&& valueCorrect + $ \value address stakeDatum' -> P.do + let cred = pfield @"credential" # address + pmatch cred $ \case + -- Should pay to a script address + PPubKeyCredential _ -> pcon PFalse + PScriptCredential _ -> P.do + stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum' + let expectedValue = paddValue # (discreteValue # stakeDatum.stakedAmount) # stValue + let ownerSignsTransaction = ptxSignedBy # ctx.txInfo # stakeDatum.owner + let valueCorrect = pdata value #== pdata expectedValue -- TODO: Needs to be >=, rather than == + ownerSignsTransaction #&& valueCorrect pconstant () From c6ce0da29c1dafa79293bda267cde1fdeda9dfbf Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Tue, 22 Feb 2022 16:05:37 +0100 Subject: [PATCH 10/15] stub of stake validator --- src/Agora/Stake.hs | 35 ++++++++++++++++++++++++++--------- 1 file changed, 26 insertions(+), 9 deletions(-) diff --git a/src/Agora/Stake.hs b/src/Agora/Stake.hs index 473d785..5d6e129 100644 --- a/src/Agora/Stake.hs +++ b/src/Agora/Stake.hs @@ -7,6 +7,7 @@ module Agora.Stake ( StakeAction (..), Stake (..), stakePolicy, + stakeValidator, stakeLocked, ) where @@ -114,15 +115,17 @@ anyInput = phoistAcyclic $ -------------------------------------------------------------------------------- -- --- # What this Policy does +-- What this Policy does -- -- For minting: -- Check that exactly 1 state thread is minted -- Check that an output exists with a state thread and a valid datum -- Check that no state thread is an input -- --- FIXME: This doesn't check that it's paid to the right script address, can we? --- +-- > FIXME: This doesn't check that it's paid to the right script address, can we? +-- > Potential solution: +-- > Encode script hash in token-name. +-- > Then, those who script hash, will be able to verify. -- -- For burning: -- Check that exactly 1 state thread is burned @@ -135,12 +138,10 @@ stakePolicy :: , KnownSymbol n , gt ~ '(ac, n, scale) ) => - Stake - gt -> - Term s (PData :--> PScriptContext :--> PUnit) + Stake gt -> + Term s (PData :--> PAsData PScriptContext :--> PUnit) stakePolicy _stake = - plam $ \_redeemer ctx'' -> P.do - PScriptContext ctx' <- pmatch ctx'' + plam $ \_redeemer ctx' -> P.do ctx <- pletFields @'["txInfo", "purpose"] ctx' txInfo' <- plet ctx.txInfo txInfo <- pletFields @'["mint", "inputs", "outputs"] txInfo' @@ -148,7 +149,6 @@ stakePolicy _stake = PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose ownSymbol <- plet $ pfield @"_0" # ownSymbol' let stValue = psingletonValue # ownSymbol # pconstant "ST" # 1 - stOf <- plet $ plam $ \v -> passetClassValueOf # ownSymbol # pconstant "ST" # v mintedST <- plet $ stOf # txInfo.mint inputST <- plet $ stOf # (pvalueSpent # pfromData txInfo') @@ -202,3 +202,20 @@ stakeLocked = phoistAcyclic $ plam $ \_stakeDatum -> -- TODO: when we extend this to support proposals, this will need to do something pcon PFalse + +-------------------------------------------------------------------------------- +stakeValidator :: + forall (gt :: MoneyClass) ac n scale s. + ( KnownSymbol ac + , KnownSymbol n + , gt ~ '(ac, n, scale) + ) => + Stake gt -> + Term s (PData :--> PData :--> PAsData PScriptContext :--> PUnit) +stakeValidator _stake = + plam $ \datum redeemer ctx' -> P.do + _ctx <- pletFields @'["txInfo", "purpose"] ctx' + let _stakeAction = punsafeCoerce redeemer :: Term s (StakeAction gt) + _stakeDatum <- pletFields @'["owner"] (punsafeCoerce datum :: Term s (StakeDatum gt)) + + pconstant () From 6f741b6dbe8cfef83cb62aa787b7b6279502c2ed Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Tue, 22 Feb 2022 22:26:26 +0100 Subject: [PATCH 11/15] tag TokenName with ValidatorHash of script ST is sent to --- src/Agora/Stake.hs | 38 +++++++++++++++++++++++--------------- src/Agora/Utils.hs | 11 +++++++++++ 2 files changed, 34 insertions(+), 15 deletions(-) diff --git a/src/Agora/Stake.hs b/src/Agora/Stake.hs index 5d6e129..84f0b82 100644 --- a/src/Agora/Stake.hs +++ b/src/Agora/Stake.hs @@ -121,11 +121,7 @@ anyInput = phoistAcyclic $ -- Check that exactly 1 state thread is minted -- Check that an output exists with a state thread and a valid datum -- Check that no state thread is an input --- --- > FIXME: This doesn't check that it's paid to the right script address, can we? --- > Potential solution: --- > Encode script hash in token-name. --- > Then, those who script hash, will be able to verify. +-- assert TokenName == ValidatorHash of the script that we pay to -- -- For burning: -- Check that exactly 1 state thread is burned @@ -148,14 +144,13 @@ stakePolicy _stake = PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose ownSymbol <- plet $ pfield @"_0" # ownSymbol' - let stValue = psingletonValue # ownSymbol # pconstant "ST" # 1 - stOf <- plet $ plam $ \v -> passetClassValueOf # ownSymbol # pconstant "ST" # v - mintedST <- plet $ stOf # txInfo.mint - inputST <- plet $ stOf # (pvalueSpent # pfromData txInfo') + valueSpent <- plet $ pvalueSpent # pfromData txInfo' + mintedST <- plet $ psymbolValueOf # ownSymbol # txInfo.mint + -- inputST <- plet $ stOf # (pvalueSpent # pfromData txInfo') let burning = P.do passert "ST at inputs must be 1" $ - inputST #== 1 + psymbolValueOf # ownSymbol # valueSpent #== 1 passert "ST burned" $ mintedST #== -1 @@ -164,7 +159,7 @@ stakePolicy _stake = anyInput @(StakeDatum gt) # pfromData txInfo' #$ plam $ \value _ stakeDatum' -> P.do - let hasST = stOf # value #== 1 + let hasST = psymbolValueOf # ownSymbol # value #== 1 let unlocked = pnot # (stakeLocked # stakeDatum') hasST #&& unlocked @@ -172,7 +167,7 @@ stakePolicy _stake = let minting = P.do passert "ST at inputs must be 0" $ - inputST #== 0 + psymbolValueOf # ownSymbol # valueSpent #== 0 passert "Minted ST must be exactly 1" $ mintedST #== 1 @@ -185,11 +180,24 @@ stakePolicy _stake = pmatch cred $ \case -- Should pay to a script address PPubKeyCredential _ -> pcon PFalse - PScriptCredential _ -> P.do + PScriptCredential validatorHash' -> P.do + validatorHash <- pletFields @'["_0"] validatorHash' stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum' - let expectedValue = paddValue # (discreteValue # stakeDatum.stakedAmount) # stValue + let stValue = + psingletonValue + # ownSymbol + -- This coerce is safe because the structure + -- of PValidatorHash is the same as PTokenName. + # punsafeCoerce validatorHash._0 + # 1 + let expectedValue = + paddValue + # (discreteValue # stakeDatum.stakedAmount) + # stValue let ownerSignsTransaction = ptxSignedBy # ctx.txInfo # stakeDatum.owner - let valueCorrect = pdata value #== pdata expectedValue -- TODO: Needs to be >=, rather than == + + -- TODO: Needs to be >=, rather than == + let valueCorrect = pdata value #== pdata expectedValue ownerSignsTransaction #&& valueCorrect pconstant () diff --git a/src/Agora/Utils.hs b/src/Agora/Utils.hs index 86b10db..dd6ff8c 100644 --- a/src/Agora/Utils.hs +++ b/src/Agora/Utils.hs @@ -95,6 +95,17 @@ pexpectJust escape ma f = PJust v -> f v PNothing -> escape +-- | Get the sum of all values belonging to a particular CurrencySymbol +psymbolValueOf :: Term s (PCurrencySymbol :--> PValue :--> PInteger) +psymbolValueOf = + phoistAcyclic $ + plam $ \sym value'' -> P.do + PValue value' <- pmatch value'' + PMap value <- pmatch value' + m' <- pexpectJust 0 (plookup # pdata sym # value) + PMap m <- pmatch (pfromData m') + pfoldr # (plam $ \x v -> (pfromData $ psndBuiltin # x) + v) # 0 # m + passetClassValueOf :: Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PInteger) passetClassValueOf = From e5afed2c46026f094b2b8cadf77cf3eb3e4c3042 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Thu, 24 Feb 2022 00:20:57 +0100 Subject: [PATCH 12/15] stake validator basics --- bench/Main.hs | 1 + src/Agora/SafeMoney.hs | 36 +++------- src/Agora/Stake.hs | 149 +++++++++++++++++++++-------------------- src/Agora/Utils.hs | 108 ++++++++++++++++++++++++++++- 4 files changed, 192 insertions(+), 102 deletions(-) diff --git a/bench/Main.hs b/bench/Main.hs index 6fc2704..c03b5e4 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -25,4 +25,5 @@ benchmarks = "full_scripts" [ bench "authorityTokenPolicy" $ Agora.authorityTokenPolicy (Agora.AuthorityToken (Value.assetClass "" "")) , bench "stakePolicy" $ Agora.stakePolicy (Agora.Stake @Agora.LQ) + , bench "stakeValidator" $ Agora.stakeValidator (Agora.Stake @Agora.LQ) ] diff --git a/src/Agora/SafeMoney.hs b/src/Agora/SafeMoney.hs index f7abcaf..6124773 100644 --- a/src/Agora/SafeMoney.hs +++ b/src/Agora/SafeMoney.hs @@ -25,15 +25,10 @@ import Prelude -------------------------------------------------------------------------------- -import Plutus.V1.Ledger.Value (AssetClass (..)) -import Plutus.V1.Ledger.Value qualified as Ledger - --------------------------------------------------------------------------------- - import Plutarch.Api.V1 import Plutarch.Builtin import Plutarch.Internal -import Plutarch.Prelude +import Plutarch.Monadic qualified as P -------------------------------------------------------------------------------- @@ -55,26 +50,15 @@ newtype Discrete (mc :: MoneyClass) (s :: S) = Discrete (Term s PInteger) deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype (Discrete mc) PInteger) -instance Num (Term s (Discrete mc)) where - (+) x y = pcon $ - Discrete . unTermCont $ do - Discrete x' <- tcont $ pmatch x - Discrete y' <- tcont $ pmatch y - pure (x' + y') - abs x = pcon $ - Discrete . unTermCont $ do - Discrete x' <- tcont $ pmatch x - pure (abs x') - negate x = pcon $ - Discrete . unTermCont $ do - Discrete x' <- tcont $ pmatch x - pure (negate x') - (*) x y = pcon $ - Discrete . unTermCont $ do - Discrete x' <- tcont $ pmatch x - Discrete y' <- tcont $ pmatch y - pure (x' * y') - fromInteger = error "Tried to `fromInteger` for a Discrete type. use `discrete` quasiquoter instead." +-- In the future, this should use plutarch-numeric + +-- | Add two `Discrete` values of the same MoneyClass +paddDiscrete :: Term s (Discrete mc :--> Discrete mc :--> Discrete mc) +paddDiscrete = phoistAcyclic $ + plam $ \x y -> P.do + Discrete x' <- pmatch x + Discrete y' <- pmatch y + pcon (Discrete $ x' + y') (^*) :: Term s (Discrete mc) -> Term s PInteger -> Term s (Discrete mc) (^*) x y = pcon $ diff --git a/src/Agora/Stake.hs b/src/Agora/Stake.hs index 84f0b82..c9aac0a 100644 --- a/src/Agora/Stake.hs +++ b/src/Agora/Stake.hs @@ -1,10 +1,11 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE UndecidableInstances #-} -- | Vote-lockable stake UTXOs holding GT module Agora.Stake ( - StakeDatum (..), - StakeAction (..), + PStakeDatum (..), + PStakeAction (..), Stake (..), stakePolicy, stakeValidator, @@ -22,6 +23,7 @@ import Prelude -------------------------------------------------------------------------------- +import Plutarch (popaque) import Plutarch.Api.V1 import Plutarch.DataRepr ( PDataFields, @@ -39,19 +41,19 @@ import Agora.Utils data Stake (gt :: MoneyClass) = Stake -data StakeAction (gt :: MoneyClass) (s :: S) +data PStakeAction (gt :: MoneyClass) (s :: S) = -- | Deposit or withdraw a discrete amount of the staked governance token - DepositWithdraw (Term s (PDataRecord '["delta" ':= Discrete gt])) + PDepositWithdraw (Term s (PDataRecord '["delta" ':= Discrete gt])) | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets - Destroy (Term s (PDataRecord '[])) + PDestroy (Term s (PDataRecord '[])) deriving stock (GHC.Generic) deriving anyclass (Generic) deriving anyclass (PIsDataRepr) deriving (PlutusType, PIsData) - via PIsDataReprInstances (StakeAction gt) + via PIsDataReprInstances (PStakeAction gt) -newtype StakeDatum (gt :: MoneyClass) (s :: S) = StakeDatum +newtype PStakeDatum (gt :: MoneyClass) (s :: S) = PStakeDatum { getStakeDatum :: ( Term s @@ -67,51 +69,7 @@ newtype StakeDatum (gt :: MoneyClass) (s :: S) = StakeDatum deriving anyclass (PIsDataRepr) deriving (PlutusType, PIsData, PDataFields) - via (PIsDataReprInstances (StakeDatum gt)) - --- | Check if any output matches the predicate -anyOutput :: - forall (datum :: PType) s. - ( PIsData datum - ) => - Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool) -anyOutput = phoistAcyclic $ - plam $ \txInfo' predicate -> P.do - txInfo <- pletFields @'["outputs"] txInfo' - pany - # ( plam $ \txOut'' -> P.do - PTxOut txOut' <- pmatch (pfromData txOut'') - txOut <- pletFields @'["value", "datumHash", "address"] txOut' - PDJust dh <- pmatch txOut.datumHash - pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case - PJust datum -> P.do - predicate # txOut.value # txOut.address # pfromData datum - PNothing -> pcon PFalse - ) - # pfromData txInfo.outputs - --- | Check if any (resolved) input matches the predicate -anyInput :: - forall (datum :: PType) s. - ( PIsData datum - ) => - Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool) -anyInput = phoistAcyclic $ - plam $ \txInfo' predicate -> P.do - txInfo <- pletFields @'["inputs"] txInfo' - pany - # ( plam $ \txInInfo'' -> P.do - PTxInInfo txInInfo' <- pmatch (pfromData txInInfo'') - let txOut'' = pfield @"resolved" # txInInfo' - PTxOut txOut' <- pmatch (pfromData txOut'') - txOut <- pletFields @'["value", "datumHash", "address"] txOut' - PDJust dh <- pmatch txOut.datumHash - pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case - PJust datum -> P.do - predicate # txOut.value # txOut.address # pfromData datum - PNothing -> pcon PFalse - ) - # pfromData txInfo.inputs + via (PIsDataReprInstances (PStakeDatum gt)) -------------------------------------------------------------------------------- -- @@ -135,7 +93,7 @@ stakePolicy :: , gt ~ '(ac, n, scale) ) => Stake gt -> - Term s (PData :--> PAsData PScriptContext :--> PUnit) + Term s PMintingPolicy stakePolicy _stake = plam $ \_redeemer ctx' -> P.do ctx <- pletFields @'["txInfo", "purpose"] ctx' @@ -144,36 +102,35 @@ stakePolicy _stake = PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose ownSymbol <- plet $ pfield @"_0" # ownSymbol' - valueSpent <- plet $ pvalueSpent # pfromData txInfo' + spentST <- plet $ psymbolValueOf # ownSymbol #$ pvalueSpent # pfromData txInfo' mintedST <- plet $ psymbolValueOf # ownSymbol # txInfo.mint - -- inputST <- plet $ stOf # (pvalueSpent # pfromData txInfo') let burning = P.do passert "ST at inputs must be 1" $ - psymbolValueOf # ownSymbol # valueSpent #== 1 + spentST #== 1 passert "ST burned" $ mintedST #== -1 passert "An unlocked input existed containing an ST" $ - anyInput @(StakeDatum gt) # pfromData txInfo' + anyInput @(PStakeDatum gt) # pfromData txInfo' #$ plam $ \value _ stakeDatum' -> P.do let hasST = psymbolValueOf # ownSymbol # value #== 1 let unlocked = pnot # (stakeLocked # stakeDatum') hasST #&& unlocked - pconstant () + popaque (pconstant ()) let minting = P.do passert "ST at inputs must be 0" $ - psymbolValueOf # ownSymbol # valueSpent #== 0 + spentST #== 0 passert "Minted ST must be exactly 1" $ mintedST #== 1 passert "A UTXO must exist with the correct output" $ - anyOutput @(StakeDatum gt) # pfromData txInfo' + anyOutput @(PStakeDatum gt) # pfromData txInfo' #$ plam $ \value address stakeDatum' -> P.do let cred = pfield @"credential" # address @@ -200,17 +157,10 @@ stakePolicy _stake = let valueCorrect = pdata value #== pdata expectedValue ownerSignsTransaction #&& valueCorrect - pconstant () + popaque (pconstant ()) pif (0 #< mintedST) minting burning --- | Check whether a Stake is locked. If it is locked, various actions are unavailable. -stakeLocked :: forall (gt :: MoneyClass) s. Term s (StakeDatum gt :--> PBool) -stakeLocked = phoistAcyclic $ - plam $ \_stakeDatum -> - -- TODO: when we extend this to support proposals, this will need to do something - pcon PFalse - -------------------------------------------------------------------------------- stakeValidator :: forall (gt :: MoneyClass) ac n scale s. @@ -219,11 +169,62 @@ stakeValidator :: , gt ~ '(ac, n, scale) ) => Stake gt -> - Term s (PData :--> PData :--> PAsData PScriptContext :--> PUnit) -stakeValidator _stake = + Term s PValidator +stakeValidator stake = plam $ \datum redeemer ctx' -> P.do - _ctx <- pletFields @'["txInfo", "purpose"] ctx' - let _stakeAction = punsafeCoerce redeemer :: Term s (StakeAction gt) - _stakeDatum <- pletFields @'["owner"] (punsafeCoerce datum :: Term s (StakeDatum gt)) + ctx <- pletFields @'["txInfo", "purpose"] ctx' + txInfo' <- plet ctx.txInfo + txInfo <- pletFields @'["mint", "inputs", "outputs"] txInfo' + let stakeAction = punsafeCoerce redeemer :: Term s (PStakeAction gt) + let stakeDatum' = punsafeCoerce datum :: Term s (PStakeDatum gt) + stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum' - pconstant () + PSpending txOutRef <- pmatch $ pfromData ctx.purpose + + PJust txInInfo <- pmatch $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfo' + ownAddress <- plet $ pfield @"address" #$ pfield @"resolved" # txInInfo + let continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo + stCurrencySymbol <- plet $ pconstant $ mintingPolicySymbol $ mkMintingPolicy (stakePolicy stake) + mintedST <- plet $ psymbolValueOf # stCurrencySymbol # txInfo.mint + spentST <- plet $ psymbolValueOf # stCurrencySymbol #$ pvalueSpent # txInfo' + + pmatch stakeAction $ \case + PDestroy _ -> P.do + passert "ST at inputs must be 1" $ + spentST #== 1 + passert "Should burn ST" $ + mintedST #== -1 + passert "Stake unlocked" $ + pnot #$ stakeLocked # stakeDatum' + popaque (pconstant ()) + PDepositWithdraw r -> P.do + passert "ST at inputs must be 1" $ + spentST #== 1 + passert "Stake unlocked" $ + pnot #$ stakeLocked # stakeDatum' + passert "A UTXO must exist with the correct output" $ + anyOutput @(PStakeDatum gt) # txInfo' + #$ plam + $ \value address newStakeDatum' -> P.do + newStakeDatum <- pletFields @'["owner", "stakedAmount"] newStakeDatum' + delta <- plet $ pfield @"delta" # r + let isScriptAddress = pdata address #== ownAddress + let correctOutputDatum = + stakeDatum.owner #== newStakeDatum.owner + #&& (paddDiscrete # stakeDatum.stakedAmount # delta) #== newStakeDatum.stakedAmount + let expectedValue = paddValue # continuingValue # (discreteValue # delta) + + -- TODO: As above, needs to be >=, rather than == + let correctValue = pdata value #== pdata expectedValue + isScriptAddress #&& correctOutputDatum #&& correctValue + + popaque (pconstant ()) + +-------------------------------------------------------------------------------- + +-- | Check whether a Stake is locked. If it is locked, various actions are unavailable. +stakeLocked :: forall (gt :: MoneyClass) s. Term s (PStakeDatum gt :--> PBool) +stakeLocked = phoistAcyclic $ + plam $ \_stakeDatum -> + -- TODO: when we extend this to support proposals, this will need to do something + pcon PFalse diff --git a/src/Agora/Utils.hs b/src/Agora/Utils.hs index dd6ff8c..47160a6 100644 --- a/src/Agora/Utils.hs +++ b/src/Agora/Utils.hs @@ -1,5 +1,25 @@ -- | Plutarch utility functions that should be upstreamed or don't belong anywhere else -module Agora.Utils (module Agora.Utils) where +module Agora.Utils ( + -- * Validator-level utility functions + passert, + pfind', + pfindDatum, + pfindDatum', + pvalueSpent, + ptxSignedBy, + paddValue, + plookup, + pfromMaybe, + psymbolValueOf, + passetClassValueOf, + passetClassValueOf', + pfindTxInByTxOutRef, + pfindMap, + + -- * Functions which should (probably) not be upstreamed + anyOutput, + anyInput, +) where -------------------------------------------------------------------------------- @@ -8,16 +28,19 @@ import Plutus.V1.Ledger.Value (AssetClass (..)) -------------------------------------------------------------------------------- import Plutarch.Api.V1 ( + PAddress, PCurrencySymbol, PDatum, PDatumHash, PMap (PMap), + PMaybeData (PDJust), PPubKeyHash, PTokenName, PTuple, PTxInInfo (PTxInInfo), PTxInfo (PTxInfo), PTxOut (PTxOut), + PTxOutRef, PValue (PValue), ) import Plutarch.Builtin (ppairDataBuiltin) @@ -25,6 +48,7 @@ import Plutarch.Internal (punsafeCoerce) import Plutarch.Monadic qualified as P -------------------------------------------------------------------------------- +-- Validator-level utility functions -- | Assert a particular bool, trace on falsehood. Use in monadic context passert :: Term s PString -> Term s PBool -> Term s k -> Term s k @@ -58,6 +82,22 @@ pfind' p = (\self x xs -> pif (p x) (pcon (PJust x)) (self # xs)) (const $ pcon PNothing) +-- | Get the first element that maps to a PJust in a list +pfindMap :: + PIsListLike list a => + Term s ((a :--> PMaybe b) :--> list a :--> PMaybe b) +pfindMap = + phoistAcyclic $ + plam $ \p -> + precList + ( \self x xs -> + -- In the future, this should use `pmatchSum`, I believe? + pmatch (p # x) $ \case + PNothing -> self # xs + PJust v -> pcon (PJust v) + ) + (const $ pcon PNothing) + -- | Find the value for a given key in an assoclist plookup :: (PEq a, PIsListLike list (PBuiltinPair a b)) => @@ -106,6 +146,7 @@ psymbolValueOf = PMap m <- pmatch (pfromData m') pfoldr # (plam $ \x v -> (pfromData $ psndBuiltin # x) + v) # 0 # m +-- | Extract amount from PValue belonging to a Plutarch-level asset class passetClassValueOf :: Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PInteger) passetClassValueOf = @@ -136,7 +177,7 @@ pmapUnionWith = phoistAcyclic $ pf <- plet $ pfstBuiltin # p ps <- plet $ psndBuiltin # p pmatch (plookup # pf # ys) $ \case - PJust v -> P.do + PJust v -> -- Data conversions here are silly, aren't they? ppairDataBuiltin # pf # (pdata (f # pfromData ps # pfromData v)) PNothing -> p @@ -177,3 +218,66 @@ pvalueSpent = phoistAcyclic $ ) # pconstant mempty # (pfield @"inputs" # txInfo) + +-- | Find the TxInInfo by a TxOutRef +pfindTxInByTxOutRef :: Term s (PTxOutRef :--> PTxInfo :--> PMaybe PTxInInfo) +pfindTxInByTxOutRef = phoistAcyclic $ + plam $ \txOutRef txInfo' -> + pmatch txInfo' $ \(PTxInfo txInfo) -> + pfindMap + # ( plam $ \txInInfo' -> + plet (pfromData txInInfo') $ \r -> + pmatch r $ \(PTxInInfo txInInfo) -> + pif + (pdata txOutRef #== pfield @"outRef" # txInInfo) + (pcon (PJust r)) + (pcon PNothing) + ) + #$ (pfield @"inputs" # txInfo) + +-------------------------------------------------------------------------------- +-- Functions which should (probably) not be upstreamed + +-- | Check if any output matches the predicate +anyOutput :: + forall (datum :: PType) s. + ( PIsData datum + ) => + Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool) +anyOutput = phoistAcyclic $ + plam $ \txInfo' predicate -> P.do + txInfo <- pletFields @'["outputs"] txInfo' + pany + # ( plam $ \txOut'' -> P.do + PTxOut txOut' <- pmatch (pfromData txOut'') + txOut <- pletFields @'["value", "datumHash", "address"] txOut' + PDJust dh <- pmatch txOut.datumHash + pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case + PJust datum -> P.do + predicate # txOut.value # txOut.address # pfromData datum + PNothing -> pcon PFalse + ) + # pfromData txInfo.outputs + +-- | Check if any (resolved) input matches the predicate +anyInput :: + forall (datum :: PType) s. + ( PIsData datum + ) => + Term s (PTxInfo :--> (PValue :--> PAddress :--> datum :--> PBool) :--> PBool) +anyInput = phoistAcyclic $ + plam $ \txInfo' predicate -> P.do + txInfo <- pletFields @'["inputs"] txInfo' + pany + # ( plam $ \txInInfo'' -> P.do + PTxInInfo txInInfo' <- pmatch (pfromData txInInfo'') + let txOut'' = pfield @"resolved" # txInInfo' + PTxOut txOut' <- pmatch (pfromData txOut'') + txOut <- pletFields @'["value", "datumHash", "address"] txOut' + PDJust dh <- pmatch txOut.datumHash + pmatch (pfindDatum' @datum # (pfield @"_0" # dh) # txInfo') $ \case + PJust datum -> P.do + predicate # txOut.value # txOut.address # pfromData datum + PNothing -> pcon PFalse + ) + # pfromData txInfo.inputs From 3599eadf0b7a97f071be55dbdf4643cbc2d916e0 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Fri, 25 Feb 2022 14:43:28 +0100 Subject: [PATCH 13/15] make hlint happy --- .github/workflows/integrate.yaml | 2 +- bench.csv | 3 ++- flake.nix | 9 ++++++--- src/Agora/AuthorityToken.hs | 21 +++++++-------------- src/Agora/SafeMoney.hs | 8 ++++---- src/Agora/SafeMoney/QQ.hs | 2 +- src/Agora/Stake.hs | 15 +++++++-------- src/Agora/Utils.hs | 28 +++++++++++++++++----------- 8 files changed, 45 insertions(+), 43 deletions(-) diff --git a/.github/workflows/integrate.yaml b/.github/workflows/integrate.yaml index 10b425d..662e290 100644 --- a/.github/workflows/integrate.yaml +++ b/.github/workflows/integrate.yaml @@ -56,7 +56,7 @@ jobs: name: mlabs authToken: ${{ secrets.CACHIX_KEY }} - - run: nix run nixpkgs#hlint -- $(git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.hs') + - run: nix run nixpkgs#haskell.packages.ghc921.hlint -- $(git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.hs') name: Run hlint check-build: diff --git a/bench.csv b/bench.csv index a82edf2..a467473 100644 --- a/bench.csv +++ b/bench.csv @@ -1,3 +1,4 @@ name,cpu,mem,size full_scripts:authorityTokenPolicy,1399431,4800,421 -full_scripts:stakePolicy,3662179,12400,1572 +full_scripts:stakePolicy,3751498,12700,1610 +full_scripts:stakeValidator,3126265,10600,1500 diff --git a/flake.nix b/flake.nix index e574172..103fea2 100644 --- a/flake.nix +++ b/flake.nix @@ -76,15 +76,18 @@ let pkgs = nixpkgsFor system; pkgs' = nixpkgsFor' system; + inherit (pkgs.haskell-nix.tools ghcVersion { + inherit (plutarch.tools) fourmolu hlint; + }) + fourmolu hlint; in pkgs.runCommand "format-check" { nativeBuildInputs = [ pkgs'.git pkgs'.fd pkgs'.haskellPackages.cabal-fmt pkgs'.nixpkgs-fmt - (pkgs.haskell-nix.tools ghcVersion { - inherit (plutarch.tools) fourmolu; - }).fourmolu + fourmolu + hlint ]; } '' export LC_CTYPE=C.UTF-8 diff --git a/src/Agora/AuthorityToken.hs b/src/Agora/AuthorityToken.hs index e32906e..041633a 100644 --- a/src/Agora/AuthorityToken.hs +++ b/src/Agora/AuthorityToken.hs @@ -20,7 +20,7 @@ import Prelude -------------------------------------------------------------------------------- -import Agora.Utils (passetClassValueOf, passetClassValueOf') +import Agora.Utils (passert, passetClassValueOf, passetClassValueOf') -------------------------------------------------------------------------------- @@ -46,9 +46,9 @@ authorityTokenPolicy params = ctx <- pletFields @'["txInfo", "purpose"] ctx' PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo txInfo <- pletFields @'["inputs", "mint"] txInfo' - let inputs = txInfo.inputs :: Term _ (PBuiltinList (PAsData PTxInInfo)) + let inputs = txInfo.inputs let authorityTokenInputs = - pfoldr' + pfoldr' @PBuiltinList ( \txInInfo' acc -> P.do PTxInInfo txInInfo <- pmatch (pfromData txInInfo') PTxOut txOut' <- pmatch $ pfromData $ pfield @"resolved" # txInInfo @@ -60,17 +60,10 @@ authorityTokenPolicy params = # inputs let mintedValue = pfromData txInfo.mint let tokenMoved = 0 #< authorityTokenInputs - PMinting sym' <- pmatch $ pfromData ctx.purpose - let sym = pfromData $ pfield @"_0" # sym' - let mintedATs = passetClassValueOf # sym # pconstant "" # mintedValue + PMinting ownSymbol' <- pmatch $ pfromData ctx.purpose + let ownSymbol = pfromData $ pfield @"_0" # ownSymbol' + let mintedATs = passetClassValueOf # ownSymbol # pconstant "" # mintedValue pif (0 #< mintedATs) - ( pif - tokenMoved - -- The authority token moved, we are good to go for minting. - (pconstant ()) - (ptraceError "Authority token did not move in minting GATs") - ) - -- We minted 0 or less Authority Tokens, we are good to go. - -- Burning is always allowed. + (passert "Authority token did not move in minting GATs" tokenMoved (pconstant ())) (pconstant ()) diff --git a/src/Agora/SafeMoney.hs b/src/Agora/SafeMoney.hs index 6124773..019c179 100644 --- a/src/Agora/SafeMoney.hs +++ b/src/Agora/SafeMoney.hs @@ -85,8 +85,8 @@ valueDiscrete :: valueDiscrete = phoistAcyclic $ plam $ \f -> pcon . Discrete $ - passetClassValueOf # (pconstant $ fromString $ symbolVal $ Proxy @ac) - # (pconstant $ fromString $ symbolVal $ Proxy @n) + passetClassValueOf # pconstant (fromString $ symbolVal $ Proxy @ac) + # pconstant (fromString $ symbolVal $ Proxy @n) # f -- NOTE: discreteValue after valueDiscrete is loses information @@ -103,8 +103,8 @@ discreteValue = phoistAcyclic $ plam $ \f -> pmatch f $ \case Discrete p -> psingletonValue - # (pconstant $ fromString $ symbolVal $ Proxy @ac) - # (pconstant $ fromString $ symbolVal $ Proxy @n) + # pconstant (fromString $ symbolVal $ Proxy @ac) + # pconstant (fromString $ symbolVal $ Proxy @n) # p -- | Create a value with a single asset class diff --git a/src/Agora/SafeMoney/QQ.hs b/src/Agora/SafeMoney/QQ.hs index 8219fa4..35d3d85 100644 --- a/src/Agora/SafeMoney/QQ.hs +++ b/src/Agora/SafeMoney/QQ.hs @@ -34,7 +34,7 @@ discrete :: QuasiQuoter discrete = QuasiQuoter discreteExp errorDiscretePat errorDiscreteType errorDiscreteDiscretelaration discreteConstant :: forall (moneyClass :: MoneyClass) s. Integer -> Term s (Discrete moneyClass) -discreteConstant n = punsafeCoerce ((pconstant n) :: Term s PInteger) +discreteConstant n = punsafeCoerce (pconstant n :: Term s PInteger) fixedToInteger :: Integer -> (Integer, Integer) -> Integer fixedToInteger places (i, f) = i * 10 ^ places + f diff --git a/src/Agora/Stake.hs b/src/Agora/Stake.hs index c9aac0a..f5834a6 100644 --- a/src/Agora/Stake.hs +++ b/src/Agora/Stake.hs @@ -55,14 +55,13 @@ data PStakeAction (gt :: MoneyClass) (s :: S) newtype PStakeDatum (gt :: MoneyClass) (s :: S) = PStakeDatum { getStakeDatum :: - ( Term - s - ( PDataRecord - '[ "stakedAmount" ':= Discrete gt - , "owner" ':= PPubKeyHash - ] - ) - ) + Term + s + ( PDataRecord + '[ "stakedAmount" ':= Discrete gt + , "owner" ':= PPubKeyHash + ] + ) } deriving stock (GHC.Generic) deriving anyclass (Generic) diff --git a/src/Agora/Utils.hs b/src/Agora/Utils.hs index 47160a6..b320339 100644 --- a/src/Agora/Utils.hs +++ b/src/Agora/Utils.hs @@ -144,7 +144,7 @@ psymbolValueOf = PMap value <- pmatch value' m' <- pexpectJust 0 (plookup # pdata sym # value) PMap m <- pmatch (pfromData m') - pfoldr # (plam $ \x v -> (pfromData $ psndBuiltin # x) + v) # 0 # m + pfoldr # plam (\x v -> pfromData (psndBuiltin # x) + v) # 0 # m -- | Extract amount from PValue belonging to a Plutarch-level asset class passetClassValueOf :: @@ -173,20 +173,22 @@ pmapUnionWith = phoistAcyclic $ PMap ys <- pmatch ys' let ls = pmap - # ( plam $ \p -> P.do + # plam + ( \p -> P.do pf <- plet $ pfstBuiltin # p ps <- plet $ psndBuiltin # p pmatch (plookup # pf # ys) $ \case PJust v -> -- Data conversions here are silly, aren't they? - ppairDataBuiltin # pf # (pdata (f # pfromData ps # pfromData v)) + ppairDataBuiltin # pf # pdata (f # pfromData ps # pfromData v) PNothing -> p ) # xs rs = pfilter - # ( plam $ \p -> - pnot # (pany # (plam $ \p' -> pfstBuiltin # p' #== pfstBuiltin # p) # xs) + # plam + ( \p -> + pnot #$ pany # plam (\p' -> pfstBuiltin # p' #== pfstBuiltin # p) # xs ) # ys pcon (PMap $ pconcat # ls # rs) @@ -199,7 +201,7 @@ paddValue = phoistAcyclic $ PValue b <- pmatch b' pcon ( PValue $ - pmapUnionWith # (plam $ \a' b' -> pmapUnionWith # (plam (+)) # a' # b') # a # b + pmapUnionWith # plam (\a' b' -> pmapUnionWith # plam (+) # a' # b') # a # b ) -- | Sum of all value at input @@ -208,12 +210,13 @@ pvalueSpent = phoistAcyclic $ plam $ \txInfo' -> pmatch txInfo' $ \(PTxInfo txInfo) -> pfoldr - # ( plam $ \txInInfo' v -> + # plam + ( \txInInfo' v -> pmatch (pfromData txInInfo') $ \(PTxInInfo txInInfo) -> paddValue - # (pmatch (pfield @"resolved" # txInInfo) $ \(PTxOut o) -> pfromData $ pfield @"value" # o) + # pmatch (pfield @"resolved" # txInInfo) (\(PTxOut o) -> pfromData $ pfield @"value" # o) # v ) # pconstant mempty @@ -225,7 +228,8 @@ pfindTxInByTxOutRef = phoistAcyclic $ plam $ \txOutRef txInfo' -> pmatch txInfo' $ \(PTxInfo txInfo) -> pfindMap - # ( plam $ \txInInfo' -> + # plam + ( \txInInfo' -> plet (pfromData txInInfo') $ \r -> pmatch r $ \(PTxInInfo txInInfo) -> pif @@ -248,7 +252,8 @@ anyOutput = phoistAcyclic $ plam $ \txInfo' predicate -> P.do txInfo <- pletFields @'["outputs"] txInfo' pany - # ( plam $ \txOut'' -> P.do + # plam + ( \txOut'' -> P.do PTxOut txOut' <- pmatch (pfromData txOut'') txOut <- pletFields @'["value", "datumHash", "address"] txOut' PDJust dh <- pmatch txOut.datumHash @@ -269,7 +274,8 @@ anyInput = phoistAcyclic $ plam $ \txInfo' predicate -> P.do txInfo <- pletFields @'["inputs"] txInfo' pany - # ( plam $ \txInInfo'' -> P.do + # plam + ( \txInInfo'' -> P.do PTxInInfo txInInfo' <- pmatch (pfromData txInInfo'') let txOut'' = pfield @"resolved" # txInInfo' PTxOut txOut' <- pmatch (pfromData txOut'') From 8bf96802b7e03ec73f4f32eccfb981e78567caf0 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Mon, 28 Feb 2022 18:26:32 +0100 Subject: [PATCH 14/15] apply suggestions --- agora.cabal | 1 + bench/Main.hs | 27 +++++++--- src/Agora/AuthorityToken.hs | 10 ++-- src/Agora/SafeMoney.hs | 100 ++++++++++++++++------------------ src/Agora/SafeMoney/QQ.hs | 19 +++++-- src/Agora/Stake.hs | 104 +++++++++++++++++++++++------------- src/Agora/Utils.hs | 63 +++++++++++++++------- src/Agora/Voting.hs | 11 +++- 8 files changed, 209 insertions(+), 126 deletions(-) diff --git a/agora.cabal b/agora.cabal index 12cd819..1a68b80 100644 --- a/agora.cabal +++ b/agora.cabal @@ -78,6 +78,7 @@ common lang ViewPatterns OverloadedRecordDot QualifiedDo + UndecidableInstances default-language: Haskell2010 diff --git a/bench/Main.hs b/bench/Main.hs index c03b5e4..150f528 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -4,14 +4,24 @@ import Prelude -------------------------------------------------------------------------------- -import Plutarch.Benchmark import Plutus.V1.Ledger.Value qualified as Value -------------------------------------------------------------------------------- -import Agora.AuthorityToken qualified as Agora -import Agora.SafeMoney qualified as Agora -import Agora.Stake qualified as Agora +import Plutarch.Benchmark + +-------------------------------------------------------------------------------- + +import Agora.AuthorityToken ( + AuthorityToken (AuthorityToken), + authorityTokenPolicy, + ) +import Agora.SafeMoney (LQ) +import Agora.Stake ( + Stake (Stake), + stakePolicy, + stakeValidator, + ) -------------------------------------------------------------------------------- @@ -23,7 +33,10 @@ benchmarks :: [NamedBenchmark] benchmarks = benchGroup "full_scripts" - [ bench "authorityTokenPolicy" $ Agora.authorityTokenPolicy (Agora.AuthorityToken (Value.assetClass "" "")) - , bench "stakePolicy" $ Agora.stakePolicy (Agora.Stake @Agora.LQ) - , bench "stakeValidator" $ Agora.stakeValidator (Agora.Stake @Agora.LQ) + [ bench "authorityTokenPolicy" $ authorityTokenPolicy authorityToken + , bench "stakePolicy" $ stakePolicy (Stake @LQ) + , bench "stakeValidator" $ stakeValidator (Stake @LQ) ] + +authorityToken :: AuthorityToken +authorityToken = AuthorityToken (Value.assetClass "" "") diff --git a/src/Agora/AuthorityToken.hs b/src/Agora/AuthorityToken.hs index 041633a..d374553 100644 --- a/src/Agora/AuthorityToken.hs +++ b/src/Agora/AuthorityToken.hs @@ -1,5 +1,8 @@ -{-# LANGUAGE PolyKinds #-} - +{- | +Module : Agora.AuthorityToken +Maintainer : emi@haskell.fyi +Description: Tokens acting as redeemable proofs of DAO authority +-} module Agora.AuthorityToken ( authorityTokenPolicy, AuthorityToken (..), @@ -28,7 +31,7 @@ import Agora.Utils (passert, passetClassValueOf, passetClassValueOf') moved while this token was minted. In effect, this means that the validator that locked such a token must have approved said transaction. Said validator should be made aware of - _this_ token's existence in order to prevent incorrect minting. + *this* token's existence in order to prevent incorrect minting. -} newtype AuthorityToken = AuthorityToken { authority :: AssetClass @@ -37,6 +40,7 @@ newtype AuthorityToken = AuthorityToken -------------------------------------------------------------------------------- +-- | Policy given 'AuthorityToken' params. authorityTokenPolicy :: AuthorityToken -> Term s (PData :--> PScriptContext :--> PUnit) diff --git a/src/Agora/SafeMoney.hs b/src/Agora/SafeMoney.hs index 019c179..ef09fe9 100644 --- a/src/Agora/SafeMoney.hs +++ b/src/Agora/SafeMoney.hs @@ -1,33 +1,40 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wwarn=missing-methods #-} -{-# OPTIONS_GHC -Wwarn=unused-imports #-} +{- | +Module : Agora.SafeMoney +Maintainer : emi@haskell.fyi +Description: Phantom-type protected types for handling money in Plutus +-} +module Agora.SafeMoney ( + -- * Types + MoneyClass, + PDiscrete, -module Agora.SafeMoney (module Agora.SafeMoney) where + -- * Utility functions + paddDiscrete, + + -- * Conversions + pdiscreteValue, + pvalueDiscrete, + + -- * Example MoneyClasses + LQ, + ADA, +) where import Data.Proxy (Proxy (Proxy)) import Data.String import GHC.TypeLits ( - CmpNat, - KnownNat, KnownSymbol, Nat, - SomeNat (..), - SomeSymbol (..), Symbol, - natVal, - someNatVal, - someSymbolVal, symbolVal, ) import Prelude -------------------------------------------------------------------------------- -import Plutarch.Api.V1 -import Plutarch.Builtin -import Plutarch.Internal +import Plutarch.Api.V1 (PValue) +import Plutarch.Builtin () +import Plutarch.Internal () import Plutarch.Monadic qualified as P -------------------------------------------------------------------------------- @@ -46,72 +53,59 @@ type MoneyClass = Nat ) -newtype Discrete (mc :: MoneyClass) (s :: S) - = Discrete (Term s PInteger) - deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype (Discrete mc) PInteger) +-- | A PDiscrete amount of currency tagged on the type level with the MoneyClass it belong sto +newtype PDiscrete (mc :: MoneyClass) (s :: S) + = PDiscrete (Term s PInteger) + deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype (PDiscrete mc) PInteger) --- In the future, this should use plutarch-numeric - --- | Add two `Discrete` values of the same MoneyClass -paddDiscrete :: Term s (Discrete mc :--> Discrete mc :--> Discrete mc) +-- | Add two `PDiscrete` values of the same MoneyClass. +paddDiscrete :: Term s (PDiscrete mc :--> PDiscrete mc :--> PDiscrete mc) paddDiscrete = phoistAcyclic $ + -- In the future, this should use plutarch-numeric plam $ \x y -> P.do - Discrete x' <- pmatch x - Discrete y' <- pmatch y - pcon (Discrete $ x' + y') - -(^*) :: Term s (Discrete mc) -> Term s PInteger -> Term s (Discrete mc) -(^*) x y = pcon $ - Discrete . unTermCont $ do - Discrete x' <- tcont $ pmatch x - pure (x' * y) + PDiscrete x' <- pmatch x + PDiscrete y' <- pmatch y + pcon (PDiscrete $ x' + y') +-- | The MoneyClass of LQ. type LQ :: MoneyClass type LQ = '("da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24", "LQ", 6) +-- | The MoneyClass of ADA. type ADA :: MoneyClass type ADA = '("", "", 6) -------------------------------------------------------------------------------- --- | Downcast a 'PValue' to a 'Discrete' unit -valueDiscrete :: +-- | Downcast a 'PValue' to a 'PDiscrete' unit. +pvalueDiscrete :: forall (moneyClass :: MoneyClass) (ac :: Symbol) (n :: Symbol) (scale :: Nat) s. ( KnownSymbol ac , KnownSymbol n , moneyClass ~ '(ac, n, scale) ) => - Term s (PValue :--> Discrete moneyClass) -valueDiscrete = phoistAcyclic $ + Term s (PValue :--> PDiscrete moneyClass) +pvalueDiscrete = phoistAcyclic $ plam $ \f -> - pcon . Discrete $ + pcon . PDiscrete $ passetClassValueOf # pconstant (fromString $ symbolVal $ Proxy @ac) # pconstant (fromString $ symbolVal $ Proxy @n) # f --- NOTE: discreteValue after valueDiscrete is loses information - --- | Get a 'PValue' from a 'Discrete' -discreteValue :: +{- | Get a 'PValue' from a 'PDiscrete'. +NOTE: pdiscreteValue after pvaluePDiscrete is loses information +-} +pdiscreteValue :: forall (moneyClass :: MoneyClass) (ac :: Symbol) (n :: Symbol) (scale :: Nat) s. ( KnownSymbol ac , KnownSymbol n , moneyClass ~ '(ac, n, scale) ) => - Term s (Discrete moneyClass :--> PValue) -discreteValue = phoistAcyclic $ + Term s (PDiscrete moneyClass :--> PValue) +pdiscreteValue = phoistAcyclic $ plam $ \f -> pmatch f $ \case - Discrete p -> + PDiscrete p -> psingletonValue # pconstant (fromString $ symbolVal $ Proxy @ac) # pconstant (fromString $ symbolVal $ Proxy @n) # p - --- | Create a value with a single asset class -psingletonValue :: forall s. Term s (PCurrencySymbol :--> PTokenName :--> PInteger :--> PValue) -psingletonValue = phoistAcyclic $ - plam $ \sym tok int -> - let innerTup = pcon $ PMap $ psingleton #$ ppairDataBuiltin # pdata tok # pdata int - outerTup = pcon $ PMap $ psingleton #$ ppairDataBuiltin # pdata sym # pdata innerTup - res = pcon $ PValue outerTup - in res diff --git a/src/Agora/SafeMoney/QQ.hs b/src/Agora/SafeMoney/QQ.hs index 35d3d85..51586fa 100644 --- a/src/Agora/SafeMoney/QQ.hs +++ b/src/Agora/SafeMoney/QQ.hs @@ -1,7 +1,10 @@ {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wwarn=missing-methods #-} -{-# OPTIONS_GHC -Wwarn=unused-imports #-} +{- | +Module : Agora.SafeMoney.QQ +Maintainer : emi@haskell.fyi +Description: Quasiquoter for SafeMoney types +-} module Agora.SafeMoney.QQ (discrete) where import GHC.Real (Ratio ((:%))) @@ -28,12 +31,20 @@ import Prelude import Plutarch.Internal (punsafeCoerce) -import Agora.SafeMoney +import Agora.SafeMoney (MoneyClass, PDiscrete) +-------------------------------------------------------------------------------- + +{- | Generate 'PDiscrete' values tagged by a particular MoneyClass + +@ + [discrete| 123.456 ADA |] :: 'Term' s ('PDiscrete' 'ADA') +@ +-} discrete :: QuasiQuoter discrete = QuasiQuoter discreteExp errorDiscretePat errorDiscreteType errorDiscreteDiscretelaration -discreteConstant :: forall (moneyClass :: MoneyClass) s. Integer -> Term s (Discrete moneyClass) +discreteConstant :: forall (moneyClass :: MoneyClass) s. Integer -> Term s (PDiscrete moneyClass) discreteConstant n = punsafeCoerce (pconstant n :: Term s PInteger) fixedToInteger :: Integer -> (Integer, Integer) -> Integer diff --git a/src/Agora/Stake.hs b/src/Agora/Stake.hs index f5834a6..fcbba21 100644 --- a/src/Agora/Stake.hs +++ b/src/Agora/Stake.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Vote-lockable stake UTXOs holding GT +{- | +Module : Agora.Stake +Maintainer : emi@haskell.fyi +Description: Vote-lockable stake UTXOs holding GT. +-} module Agora.Stake ( PStakeDatum (..), PStakeAction (..), @@ -24,27 +24,52 @@ import Prelude -------------------------------------------------------------------------------- import Plutarch (popaque) -import Plutarch.Api.V1 +import Plutarch.Api.V1 ( + PCredential (PPubKeyCredential, PScriptCredential), + PMintingPolicy, + PPubKeyHash, + PScriptPurpose (PMinting, PSpending), + PValidator, + mintingPolicySymbol, + mkMintingPolicy, + ) import Plutarch.DataRepr ( PDataFields, PIsDataReprInstances (PIsDataReprInstances), ) -import Plutarch.Internal +import Plutarch.Internal (punsafeCoerce) import Plutarch.Monadic qualified as P -------------------------------------------------------------------------------- -import Agora.SafeMoney -import Agora.Utils +import Agora.SafeMoney ( + MoneyClass, + PDiscrete, + paddDiscrete, + pdiscreteValue, + ) +import Agora.Utils ( + anyInput, + anyOutput, + paddValue, + passert, + pfindTxInByTxOutRef, + psingletonValue, + psymbolValueOf, + ptxSignedBy, + pvalueSpent, + ) -------------------------------------------------------------------------------- +-- | Parameters for creating Stake scripts. data Stake (gt :: MoneyClass) = Stake +-- | Plutarch-level redeemer for Stake scripts. data PStakeAction (gt :: MoneyClass) (s :: S) - = -- | Deposit or withdraw a discrete amount of the staked governance token - PDepositWithdraw (Term s (PDataRecord '["delta" ':= Discrete gt])) - | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets + = -- | Deposit or withdraw a discrete amount of the staked governance token. + PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete gt])) + | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets. PDestroy (Term s (PDataRecord '[])) deriving stock (GHC.Generic) deriving anyclass (Generic) @@ -53,15 +78,10 @@ data PStakeAction (gt :: MoneyClass) (s :: S) (PlutusType, PIsData) via PIsDataReprInstances (PStakeAction gt) +-- | Plutarch-level datum for Stake scripts. newtype PStakeDatum (gt :: MoneyClass) (s :: S) = PStakeDatum { getStakeDatum :: - Term - s - ( PDataRecord - '[ "stakedAmount" ':= Discrete gt - , "owner" ':= PPubKeyHash - ] - ) + Term s (PDataRecord '["stakedAmount" ':= PDiscrete gt, "owner" ':= PPubKeyHash]) } deriving stock (GHC.Generic) deriving anyclass (Generic) @@ -71,20 +91,21 @@ newtype PStakeDatum (gt :: MoneyClass) (s :: S) = PStakeDatum via (PIsDataReprInstances (PStakeDatum gt)) -------------------------------------------------------------------------------- --- --- What this Policy does --- --- For minting: --- Check that exactly 1 state thread is minted --- Check that an output exists with a state thread and a valid datum --- Check that no state thread is an input --- assert TokenName == ValidatorHash of the script that we pay to --- --- For burning: --- Check that exactly 1 state thread is burned --- Check that datum at state thread is valid and not locked --- +{- What this Policy does + + For minting: + Check that exactly one state thread is minted + Check that an output exists with a state thread and a valid datum + Check that no state thread is an input + assert TokenName == ValidatorHash of the script that we pay to + + For burning: + Check that exactly one state thread is burned + Check that datum at state thread is valid and not locked +-} -------------------------------------------------------------------------------- + +-- | Policy for Stake state threads stakePolicy :: forall (gt :: MoneyClass) ac n scale s. ( KnownSymbol ac @@ -148,9 +169,12 @@ stakePolicy _stake = # 1 let expectedValue = paddValue - # (discreteValue # stakeDatum.stakedAmount) + # (pdiscreteValue # stakeDatum.stakedAmount) # stValue - let ownerSignsTransaction = ptxSignedBy # ctx.txInfo # stakeDatum.owner + let ownerSignsTransaction = + ptxSignedBy + # ctx.txInfo + # stakeDatum.owner -- TODO: Needs to be >=, rather than == let valueCorrect = pdata value #== pdata expectedValue @@ -161,6 +185,8 @@ stakePolicy _stake = pif (0 #< mintedST) minting burning -------------------------------------------------------------------------------- + +-- | Validator intended for Stake UTXOs to live in stakeValidator :: forall (gt :: MoneyClass) ac n scale s. ( KnownSymbol ac @@ -174,8 +200,12 @@ stakeValidator stake = ctx <- pletFields @'["txInfo", "purpose"] ctx' txInfo' <- plet ctx.txInfo txInfo <- pletFields @'["mint", "inputs", "outputs"] txInfo' - let stakeAction = punsafeCoerce redeemer :: Term s (PStakeAction gt) - let stakeDatum' = punsafeCoerce datum :: Term s (PStakeDatum gt) + + -- Coercion is safe in that if coercion fails we crash hard. + let stakeAction :: Term _ (PStakeAction gt) + stakeAction = pfromData $ punsafeCoerce redeemer + stakeDatum' :: Term _ (PStakeDatum gt) + stakeDatum' = pfromData $ punsafeCoerce datum stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum' PSpending txOutRef <- pmatch $ pfromData ctx.purpose @@ -211,7 +241,7 @@ stakeValidator stake = let correctOutputDatum = stakeDatum.owner #== newStakeDatum.owner #&& (paddDiscrete # stakeDatum.stakedAmount # delta) #== newStakeDatum.stakedAmount - let expectedValue = paddValue # continuingValue # (discreteValue # delta) + let expectedValue = paddValue # continuingValue # (pdiscreteValue # delta) -- TODO: As above, needs to be >=, rather than == let correctValue = pdata value #== pdata expectedValue diff --git a/src/Agora/Utils.hs b/src/Agora/Utils.hs index b320339..c0967f0 100644 --- a/src/Agora/Utils.hs +++ b/src/Agora/Utils.hs @@ -1,4 +1,8 @@ --- | Plutarch utility functions that should be upstreamed or don't belong anywhere else +{- | +Module : Agora.Utils +Maintainer : emi@haskell.fyi +Description: Plutarch utility functions that should be upstreamed or don't belong anywhere else +-} module Agora.Utils ( -- * Validator-level utility functions passert, @@ -14,6 +18,7 @@ module Agora.Utils ( passetClassValueOf, passetClassValueOf', pfindTxInByTxOutRef, + psingletonValue, pfindMap, -- * Functions which should (probably) not be upstreamed @@ -50,7 +55,7 @@ import Plutarch.Monadic qualified as P -------------------------------------------------------------------------------- -- Validator-level utility functions --- | Assert a particular bool, trace on falsehood. Use in monadic context +-- | Assert a particular 'PBool', trace if false. Use in monadic context. passert :: Term s PString -> Term s PBool -> Term s k -> Term s k passert errorMessage check k = pif check k (ptraceError errorMessage) @@ -61,18 +66,20 @@ pfindDatum = phoistAcyclic $ PTxInfo txInfo' <- pmatch txInfo'' plookupTuple # datumHash #$ pfield @"data" # txInfo' --- | Find a datum with the given hash. NOTE: this is unsafe in the sense that, if the data layout is wrong, this is UB. +{- | Find a datum with the given hash. +NOTE: this is unsafe in the sense that, if the data layout is wrong, this is UB. +-} pfindDatum' :: PIsData a => Term s (PDatumHash :--> PTxInfo :--> PMaybe (PAsData a)) pfindDatum' = phoistAcyclic $ plam $ \dh x -> punsafeCoerce $ pfindDatum # dh # x --- | Check if a PubKeyHash signs this transaction +-- | Check if a PubKeyHash signs this transaction. ptxSignedBy :: Term s (PTxInfo :--> PAsData PPubKeyHash :--> PBool) ptxSignedBy = phoistAcyclic $ plam $ \txInfo' pkh -> P.do txInfo <- pletFields @'["signatories"] txInfo' pelem @PBuiltinList # pkh # txInfo.signatories --- | Get the first element that matches a predicate or return Nothing +-- | Get the first element that matches a predicate or return Nothing. pfind' :: PIsListLike list a => (Term s a -> Term s PBool) -> @@ -82,7 +89,7 @@ pfind' p = (\self x xs -> pif (p x) (pcon (PJust x)) (self # xs)) (const $ pcon PNothing) --- | Get the first element that maps to a PJust in a list +-- | Get the first element that maps to a PJust in a list. pfindMap :: PIsListLike list a => Term s ((a :--> PMaybe b) :--> list a :--> PMaybe b) @@ -98,7 +105,7 @@ pfindMap = ) (const $ pcon PNothing) --- | Find the value for a given key in an assoclist +-- | Find the value for a given key in an associative list. plookup :: (PEq a, PIsListLike list (PBuiltinPair a b)) => Term s (a :--> list (PBuiltinPair a b) :--> PMaybe b) @@ -109,7 +116,7 @@ plookup = PNothing -> pcon PNothing PJust p -> pcon (PJust (psndBuiltin # p)) --- | Find the value for a given key in an assoclist which uses 'PTuple's +-- | Find the value for a given key in an assoclist which uses 'PTuple's. plookupTuple :: (PEq a, PIsListLike list (PAsData (PTuple a b)), PIsData a, PIsData b) => Term s (a :--> list (PAsData (PTuple a b)) :--> PMaybe b) @@ -120,7 +127,7 @@ plookupTuple = PNothing -> pcon PNothing PJust p -> pcon (PJust (pfield @"_1" # pfromData p)) --- | Extract a Maybe by providing a default value in case of Just +-- | Extract a Maybe by providing a default value in case of Just. pfromMaybe :: forall a s. Term s (a :--> PMaybe a :--> a) pfromMaybe = phoistAcyclic $ plam $ \e a -> @@ -128,14 +135,19 @@ pfromMaybe = phoistAcyclic $ PJust a' -> a' PNothing -> e --- | Escape with a particular value on expecting 'Just'. For use in monadic context -pexpectJust :: forall r a s. Term s r -> Term s (PMaybe a) -> (Term s a -> Term s r) -> Term s r +-- | Escape with a particular value on expecting 'Just'. For use in monadic context. +pexpectJust :: + forall r a s. + Term s r -> + Term s (PMaybe a) -> + (Term s a -> Term s r) -> + Term s r pexpectJust escape ma f = pmatch ma $ \case PJust v -> f v PNothing -> escape --- | Get the sum of all values belonging to a particular CurrencySymbol +-- | Get the sum of all values belonging to a particular CurrencySymbol. psymbolValueOf :: Term s (PCurrencySymbol :--> PValue :--> PInteger) psymbolValueOf = phoistAcyclic $ @@ -146,7 +158,7 @@ psymbolValueOf = PMap m <- pmatch (pfromData m') pfoldr # plam (\x v -> pfromData (psndBuiltin # x) + v) # 0 # m --- | Extract amount from PValue belonging to a Plutarch-level asset class +-- | Extract amount from PValue belonging to a Plutarch-level asset class. passetClassValueOf :: Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PInteger) passetClassValueOf = @@ -159,12 +171,12 @@ passetClassValueOf = v <- pexpectJust 0 (plookup # pdata token # m) pfromData v --- | Extract amount from PValue belonging to a Haskell-level AssetClass +-- | Extract amount from PValue belonging to a Haskell-level AssetClass. passetClassValueOf' :: AssetClass -> Term s (PValue :--> PInteger) passetClassValueOf' (AssetClass (sym, token)) = passetClassValueOf # pconstant sym # pconstant token --- | Union two maps using a merge function on collisions +-- | Union two maps using a merge function on collisions. pmapUnionWith :: forall k v s. PIsData v => Term s ((v :--> v :--> v) :--> PMap k v :--> PMap k v :--> PMap k v) pmapUnionWith = phoistAcyclic $ -- TODO: this function is kinda suspect. I feel like a lot of optimizations could be done here @@ -204,7 +216,7 @@ paddValue = phoistAcyclic $ pmapUnionWith # plam (\a' b' -> pmapUnionWith # plam (+) # a' # b') # a # b ) --- | Sum of all value at input +-- | Sum of all value at input. pvalueSpent :: Term s (PTxInfo :--> PValue) pvalueSpent = phoistAcyclic $ plam $ \txInfo' -> @@ -216,13 +228,15 @@ pvalueSpent = phoistAcyclic $ (pfromData txInInfo') $ \(PTxInInfo txInInfo) -> paddValue - # pmatch (pfield @"resolved" # txInInfo) (\(PTxOut o) -> pfromData $ pfield @"value" # o) + # pmatch + (pfield @"resolved" # txInInfo) + (\(PTxOut o) -> pfromData $ pfield @"value" # o) # v ) # pconstant mempty # (pfield @"inputs" # txInfo) --- | Find the TxInInfo by a TxOutRef +-- | Find the TxInInfo by a TxOutRef. pfindTxInByTxOutRef :: Term s (PTxOutRef :--> PTxInfo :--> PMaybe PTxInInfo) pfindTxInByTxOutRef = phoistAcyclic $ plam $ \txOutRef txInfo' -> @@ -242,7 +256,7 @@ pfindTxInByTxOutRef = phoistAcyclic $ -------------------------------------------------------------------------------- -- Functions which should (probably) not be upstreamed --- | Check if any output matches the predicate +-- | Check if any output matches the predicate. anyOutput :: forall (datum :: PType) s. ( PIsData datum @@ -264,7 +278,7 @@ anyOutput = phoistAcyclic $ ) # pfromData txInfo.outputs --- | Check if any (resolved) input matches the predicate +-- | Check if any (resolved) input matches the predicate. anyInput :: forall (datum :: PType) s. ( PIsData datum @@ -287,3 +301,12 @@ anyInput = phoistAcyclic $ PNothing -> pcon PFalse ) # pfromData txInfo.inputs + +-- | Create a value with a single asset class. +psingletonValue :: forall s. Term s (PCurrencySymbol :--> PTokenName :--> PInteger :--> PValue) +psingletonValue = phoistAcyclic $ + plam $ \sym tok int -> + let innerTup = pcon $ PMap $ psingleton #$ ppairDataBuiltin # pdata tok # pdata int + outerTup = pcon $ PMap $ psingleton #$ ppairDataBuiltin # pdata sym # pdata innerTup + res = pcon $ PValue outerTup + in res diff --git a/src/Agora/Voting.hs b/src/Agora/Voting.hs index 74354a5..5436960 100644 --- a/src/Agora/Voting.hs +++ b/src/Agora/Voting.hs @@ -1,4 +1,11 @@ --- | Types for votes and vote counting -module Agora.Voting (Vote (..)) where +{- | +Module : Agora.Voting +Maintainer : emi@haskell.fyi +Description: Types for votes and vote counting +-} +module Agora.Voting ( + Vote (..), +) where +-- | Type representing direction of vote. data Vote = InFavorOf | OpposedTo From ffce843a03d5f650d5ca6750eb8498b2e07da30e Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Tue, 1 Mar 2022 13:14:51 +0100 Subject: [PATCH 15/15] apply remaining suggestions --- src/Agora/AuthorityToken.hs | 4 +++- src/Agora/SafeMoney.hs | 16 +++++++++------- src/Agora/SafeMoney/QQ.hs | 4 +++- src/Agora/Stake.hs | 6 ++++-- src/Agora/Utils.hs | 4 +++- 5 files changed, 22 insertions(+), 12 deletions(-) diff --git a/src/Agora/AuthorityToken.hs b/src/Agora/AuthorityToken.hs index d374553..64dcfc7 100644 --- a/src/Agora/AuthorityToken.hs +++ b/src/Agora/AuthorityToken.hs @@ -1,7 +1,9 @@ {- | Module : Agora.AuthorityToken Maintainer : emi@haskell.fyi -Description: Tokens acting as redeemable proofs of DAO authority +Description: Tokens acting as redeemable proofs of DAO authority. + +Tokens acting as redeemable proofs of DAO authority. -} module Agora.AuthorityToken ( authorityTokenPolicy, diff --git a/src/Agora/SafeMoney.hs b/src/Agora/SafeMoney.hs index ef09fe9..f361e22 100644 --- a/src/Agora/SafeMoney.hs +++ b/src/Agora/SafeMoney.hs @@ -1,7 +1,9 @@ {- | Module : Agora.SafeMoney Maintainer : emi@haskell.fyi -Description: Phantom-type protected types for handling money in Plutus +Description: Phantom-type protected types for handling money in Plutus. + +Phantom-type protected types for handling money in Plutus. -} module Agora.SafeMoney ( -- * Types @@ -43,7 +45,7 @@ import Agora.Utils -------------------------------------------------------------------------------- --- | Type-level unique identifier for an AssetClass +-- | Type-level unique identifier for an `AssetClass` type MoneyClass = ( -- AssetClass Symbol @@ -53,12 +55,12 @@ type MoneyClass = Nat ) --- | A PDiscrete amount of currency tagged on the type level with the MoneyClass it belong sto +-- | A `PDiscrete` amount of currency tagged on the type level with the `MoneyClass` it belong sto newtype PDiscrete (mc :: MoneyClass) (s :: S) = PDiscrete (Term s PInteger) deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype (PDiscrete mc) PInteger) --- | Add two `PDiscrete` values of the same MoneyClass. +-- | Add two `PDiscrete` values of the same `MoneyClass`. paddDiscrete :: Term s (PDiscrete mc :--> PDiscrete mc :--> PDiscrete mc) paddDiscrete = phoistAcyclic $ -- In the future, this should use plutarch-numeric @@ -77,7 +79,7 @@ type ADA = '("", "", 6) -------------------------------------------------------------------------------- --- | Downcast a 'PValue' to a 'PDiscrete' unit. +-- | Downcast a `PValue` to a `PDiscrete` unit. pvalueDiscrete :: forall (moneyClass :: MoneyClass) (ac :: Symbol) (n :: Symbol) (scale :: Nat) s. ( KnownSymbol ac @@ -92,8 +94,8 @@ pvalueDiscrete = phoistAcyclic $ # pconstant (fromString $ symbolVal $ Proxy @n) # f -{- | Get a 'PValue' from a 'PDiscrete'. -NOTE: pdiscreteValue after pvaluePDiscrete is loses information +{- | Get a `PValue` from a `PDiscrete`. + __NOTE__: `pdiscreteValue` after `pvalueDiscrete` is loses information -} pdiscreteValue :: forall (moneyClass :: MoneyClass) (ac :: Symbol) (n :: Symbol) (scale :: Nat) s. diff --git a/src/Agora/SafeMoney/QQ.hs b/src/Agora/SafeMoney/QQ.hs index 51586fa..96ec4c7 100644 --- a/src/Agora/SafeMoney/QQ.hs +++ b/src/Agora/SafeMoney/QQ.hs @@ -3,7 +3,9 @@ {- | Module : Agora.SafeMoney.QQ Maintainer : emi@haskell.fyi -Description: Quasiquoter for SafeMoney types +Description: Quasiquoter for SafeMoney types. + +Quasiquoter for SafeMoney types. -} module Agora.SafeMoney.QQ (discrete) where diff --git a/src/Agora/Stake.hs b/src/Agora/Stake.hs index fcbba21..a4dcc24 100644 --- a/src/Agora/Stake.hs +++ b/src/Agora/Stake.hs @@ -2,6 +2,8 @@ Module : Agora.Stake Maintainer : emi@haskell.fyi Description: Vote-lockable stake UTXOs holding GT. + +Vote-lockable stake UTXOs holding GT. -} module Agora.Stake ( PStakeDatum (..), @@ -105,7 +107,7 @@ newtype PStakeDatum (gt :: MoneyClass) (s :: S) = PStakeDatum -} -------------------------------------------------------------------------------- --- | Policy for Stake state threads +-- | Policy for Stake state threads. stakePolicy :: forall (gt :: MoneyClass) ac n scale s. ( KnownSymbol ac @@ -186,7 +188,7 @@ stakePolicy _stake = -------------------------------------------------------------------------------- --- | Validator intended for Stake UTXOs to live in +-- | Validator intended for Stake UTXOs to live in. stakeValidator :: forall (gt :: MoneyClass) ac n scale s. ( KnownSymbol ac diff --git a/src/Agora/Utils.hs b/src/Agora/Utils.hs index c0967f0..124c57b 100644 --- a/src/Agora/Utils.hs +++ b/src/Agora/Utils.hs @@ -1,7 +1,9 @@ {- | Module : Agora.Utils Maintainer : emi@haskell.fyi -Description: Plutarch utility functions that should be upstreamed or don't belong anywhere else +Description: Plutarch utility functions that should be upstreamed or don't belong anywhere else. + +Plutarch utility functions that should be upstreamed or don't belong anywhere else. -} module Agora.Utils ( -- * Validator-level utility functions