diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index 44199a6..610d49a 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -19,9 +19,12 @@ module Agora.Stake ( -------------------------------------------------------------------------------- +import Data.Proxy (Proxy (Proxy)) +import Data.String (IsString (fromString)) import GHC.Generics qualified as GHC import GHC.TypeLits ( KnownSymbol, + symbolVal, ) import Generics.SOP (Generic, I (I)) import Prelude @@ -50,6 +53,7 @@ import Plutarch.DataRepr ( ) import Plutarch.Internal (punsafeCoerce) import Plutarch.Monadic qualified as P +import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) -------------------------------------------------------------------------------- @@ -65,6 +69,9 @@ import Agora.Utils ( paddValue, passert, pfindTxInByTxOutRef, + pgeqBy, + pgeqBy', + pgeqBySymbol, psingletonValue, psymbolValueOf, ptxSignedBy, @@ -200,8 +207,28 @@ stakePolicy _stake = # ctx.txInfo # stakeDatum.owner - -- TODO: Needs to be >=, rather than == - let valueCorrect = pdata value #== pdata expectedValue + -- TODO: This is quite inefficient now, as it does two lookups + -- instead of a more efficient single pass, + -- but it doesn't really matter for this. At least it's correct. + let valueCorrect = + foldr1 + (#&&) + [ pgeqBy' (AssetClass ("", "")) # value # expectedValue + , pgeqBy' + ( AssetClass + ( fromString . symbolVal $ Proxy @ac + , fromString . symbolVal $ Proxy @n + ) + ) + # value + # expectedValue + , pgeqBy + # ownSymbol + # tn + # value + # expectedValue + ] + ownerSignsTransaction #&& valueCorrect popaque (pconstant ()) @@ -274,9 +301,27 @@ stakeValidator stake = #&& (paddDiscrete # stakeDatum.stakedAmount # delta) #== newStakeDatum.stakedAmount let expectedValue = paddValue # continuingValue # (pdiscreteValue # delta) - -- TODO: As above, needs to be >=, rather than == - let correctValue = pdata value #== pdata expectedValue - isScriptAddress #&& correctOutputDatum #&& correctValue + -- TODO: Same as above. This is quite inefficient now, as it does two lookups + -- instead of a more efficient single pass, + -- but it doesn't really matter for this. At least it's correct. + let valueCorrect = + foldr1 + (#&&) + [ pgeqBy' (AssetClass ("", "")) # value # expectedValue + , pgeqBy' + ( AssetClass + ( fromString . symbolVal $ Proxy @ac + , fromString . symbolVal $ Proxy @n + ) + ) + # value + # expectedValue + , pgeqBySymbol + # stCurrencySymbol + # value + # expectedValue + ] + isScriptAddress #&& correctOutputDatum #&& valueCorrect popaque (pconstant ()) diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index 2afa33a..8f70a2f 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -19,6 +19,9 @@ module Agora.Utils ( psymbolValueOf, passetClassValueOf, passetClassValueOf', + pgeqBy, + pgeqBySymbol, + pgeqBy', pfindTxInByTxOutRef, psingletonValue, pfindMap, @@ -180,6 +183,27 @@ passetClassValueOf' :: AssetClass -> Term s (PValue :--> PInteger) passetClassValueOf' (AssetClass (sym, token)) = passetClassValueOf # pconstant sym # pconstant token +-- | Return '>=' on two values comparing by only a particular AssetClass +pgeqBy :: Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PValue :--> PBool) +pgeqBy = + phoistAcyclic $ + plam $ \cs tn a b -> + passetClassValueOf # cs # tn # b #<= passetClassValueOf # cs # tn # a + +-- | Return '>=' on two values comparing by only a particular AssetClass +pgeqBySymbol :: Term s (PCurrencySymbol :--> PValue :--> PValue :--> PBool) +pgeqBySymbol = + phoistAcyclic $ + plam $ \cs a b -> + psymbolValueOf # cs # b #<= psymbolValueOf # cs # a + +-- | Return '>=' on two values comparing by only a particular Haskell-level AssetClass +pgeqBy' :: AssetClass -> Term s (PValue :--> PValue :--> PBool) +pgeqBy' ac = + phoistAcyclic $ + plam $ \a b -> + passetClassValueOf' ac # b #<= passetClassValueOf' ac # a + -- | 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 $