diff --git a/agora.cabal b/agora.cabal index 041af40..ea06771 100644 --- a/agora.cabal +++ b/agora.cabal @@ -123,6 +123,7 @@ library exposed-modules: Agora.AuthorityToken Agora.Effect + Agora.Effect.NoOp Agora.Governor Agora.MultiSig Agora.Proposal @@ -151,11 +152,11 @@ test-suite agora-test main-is: Spec.hs hs-source-dirs: agora-test other-modules: + Spec.AuthorityToken Spec.Model.MultiSig Spec.Sample.Stake Spec.Stake Spec.Util - Spec.AuthorityToken build-depends: agora diff --git a/agora/Agora/Effect.hs b/agora/Agora/Effect.hs index e8c3794..3a3b1e9 100644 --- a/agora/Agora/Effect.hs +++ b/agora/Agora/Effect.hs @@ -5,17 +5,13 @@ Description: Helpers for constructing effects Helpers for constructing effects. -} -module Agora.Effect ( - makeEffect, - noopEffect, -) where +module Agora.Effect (makeEffect) where import Agora.AuthorityToken (singleAuthorityTokenBurned) import Agora.Utils (passert) -import Plutarch (popaque) import Plutarch.Api.V1 (PCurrencySymbol, PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator, PValue) -import Plutarch.Internal (punsafeCoerce) import Plutarch.Monadic qualified as P +import Plutarch.TryFrom (PTryFrom, ptryFrom) import Plutus.V1.Ledger.Value (CurrencySymbol) -------------------------------------------------------------------------------- @@ -28,7 +24,7 @@ import Plutus.V1.Ledger.Value (CurrencySymbol) -} makeEffect :: forall (datum :: PType). - PIsData datum => + (PIsData datum, PTryFrom PData datum) => CurrencySymbol -> (forall (s :: S). Term s PCurrencySymbol -> Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) -> ClosedTerm PValidator @@ -37,29 +33,24 @@ makeEffect gatCs' f = ctx <- pletFields @'["txInfo", "purpose"] ctx' txInfo' <- plet ctx.txInfo - -- TODO: Use PTryFrom - let datum' :: Term _ datum - datum' = pfromData $ punsafeCoerce datum + -- convert input datum, PData, into desierable type + -- the way this conversion is performed should be defined + -- by PTryFrom for each datum in effect script. + (datum', _) <- ptryFrom @datum datum + -- ensure purpose is Spending. PSpending txOutRef <- pmatch $ pfromData ctx.purpose txOutRef' <- plet (pfield @"_0" # txOutRef) + -- fetch minted values to ensure single GAT is burned txInfo <- pletFields @'["mint"] txInfo' let mint :: Term _ PValue mint = txInfo.mint + -- fetch script context gatCs <- plet $ pconstant gatCs' passert "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint + -- run effect function f gatCs datum' txOutRef' txInfo' - --------------------------------------------------------------------------------- - --- | Dummy effect which can only burn its GAT. -noopEffect :: CurrencySymbol -> ClosedTerm PValidator -noopEffect = - ( `makeEffect` - \_gatCs (_datum :: Term _ PUnit) _txOutRef _txInfo -> P.do - popaque (pconstant ()) - ) diff --git a/agora/Agora/Effect/NoOp.hs b/agora/Agora/Effect/NoOp.hs new file mode 100644 index 0000000..90782e9 --- /dev/null +++ b/agora/Agora/Effect/NoOp.hs @@ -0,0 +1,33 @@ +{- | +Module : Agora.Effect.NoOp +Maintainer : seungheon.ooh@gmail.com +Description: Dummy dumb dumb effect. + +A dumb effect that only burns its GAT. +-} +module Agora.Effect.NoOp (noOpValidator, PNoOp) where + +import Control.Applicative (Const) + +import Agora.Effect (makeEffect) +import Plutarch (popaque) +import Plutarch.Api.V1 (PValidator) +import Plutarch.TryFrom (PTryFrom (..)) +import Plutus.V1.Ledger.Value (CurrencySymbol) + +newtype PNoOp (s :: S) = PNoOp (Term s PUnit) + deriving (PlutusType, PIsData) via (DerivePNewtype PNoOp PUnit) + +instance PTryFrom PData PNoOp where + type PTryFromExcess PData PNoOp = Const () + ptryFrom' _ cont = + -- JUSTIFICATION: + -- We don't care anything about data. + -- It should always be reduced to Unit. + cont (pcon $ PNoOp (pconstant ()), ()) + +-- | Dummy effect which can only burn its GAT. +noOpValidator :: CurrencySymbol -> ClosedTerm PValidator +noOpValidator curr = makeEffect curr $ + \_ (_datum :: Term s PNoOp) _ _ -> P.do + popaque (pconstant ()) diff --git a/flake.nix b/flake.nix index c6522d6..3b1756a 100644 --- a/flake.nix +++ b/flake.nix @@ -50,8 +50,10 @@ projectFor = system: let pkgs = nixpkgsFor system; - in let pkgs' = nixpkgsFor' system; - in (nixpkgsFor system).haskell-nix.cabalProject' { + in + let pkgs' = nixpkgsFor' system; + in + (nixpkgsFor system).haskell-nix.cabalProject' { src = ./.; compiler-nix-name = ghcVersion; inherit (plutarch) cabalProjectLocal; @@ -120,16 +122,18 @@ inherit (plutarch.tools) fourmolu; }) fourmolu; - in pkgs.runCommand "format-check" { - nativeBuildInputs = [ - pkgs'.git - pkgs'.fd - pkgs'.haskellPackages.cabal-fmt - pkgs'.nixpkgs-fmt - fourmolu - pkgs'.haskell.packages."${ghcVersion}".hlint - ]; - } '' + in + pkgs.runCommand "format-check" + { + nativeBuildInputs = [ + pkgs'.git + pkgs'.fd + pkgs'.haskellPackages.cabal-fmt + pkgs'.nixpkgs-fmt + fourmolu + pkgs'.haskell.packages."${ghcVersion}".hlint + ]; + } '' export LC_CTYPE=C.UTF-8 export LC_ALL=C.UTF-8 export LANG=C.UTF-8 @@ -139,20 +143,23 @@ mkdir $out ''; - in { + in + { project = perSystem projectFor; flake = perSystem (system: (projectFor system).flake { }); packages = perSystem (system: self.flake.${system}.packages // { - haddock = let - agora-doc = self.flake.${system}.packages."agora:lib:agora".doc; - pkgs = nixpkgsFor system; - in pkgs.runCommand "haddock-merge" { } '' - cd ${self} - mkdir $out - cp -r ${agora-doc}/share/doc/* $out - ''; + haddock = + let + agora-doc = self.flake.${system}.packages."agora:lib:agora".doc; + pkgs = nixpkgsFor system; + in + pkgs.runCommand "haddock-merge" { } '' + cd ${self} + mkdir $out + cp -r ${agora-doc}/share/doc/* $out + ''; }); # Define what we want to test @@ -163,9 +170,10 @@ agora-test = self.flake.${system}.packages."agora:test:agora-test"; }); check = perSystem (system: - (nixpkgsFor system).runCommand "combined-test" { - checksss = builtins.attrValues self.checks.${system}; - } '' + (nixpkgsFor system).runCommand "combined-test" + { + checksss = builtins.attrValues self.checks.${system}; + } '' echo $checksss touch $out '');