From 564b1c4e665b89c64f50cfb433584971dd3fae74 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Mon, 20 Jun 2022 15:59:35 +0200 Subject: [PATCH 1/9] init servant-based API for script exporting --- agora-scripts/API.hs | 130 +++++++++++++++++++++++++++++++++++++++ agora-scripts/Options.hs | 21 +++---- agora-scripts/Scripts.hs | 108 +------------------------------- agora.cabal | 10 ++- 4 files changed, 149 insertions(+), 120 deletions(-) create mode 100644 agora-scripts/API.hs diff --git a/agora-scripts/API.hs b/agora-scripts/API.hs new file mode 100644 index 0000000..bba06a3 --- /dev/null +++ b/agora-scripts/API.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE TemplateHaskell #-} +{- | +Module : API +Maintainer : emi@haskell.fyi +Description: API for script exporter. + +API for script exporter. +-} + +module API (AgoraScripts(..), ScriptParams(..), API, agoraScripts, runServer) where + +import Servant.API (type (:>), ReqBody, JSON, Post) +import PlutusLedgerApi.V1 (TxOutRef) +import Data.Tagged (Tagged) +import Agora.SafeMoney (GTTag) +import PlutusLedgerApi.V1.Value (AssetClass, CurrencySymbol) +import qualified Data.Aeson as Aeson +import qualified GHC.Generics as GHC +import Agora.ScriptInfo (PolicyInfo, ValidatorInfo, mkPolicyInfo, mkValidatorInfo) +import Agora.Stake (Stake(..)) +import Agora.Proposal (Proposal(..)) +import Agora.AuthorityToken (AuthorityToken(..), authorityTokenPolicy) +import Agora.Governor (Governor(..)) +import Development.GitRev (gitBranch, gitHash) +import qualified Agora.Governor as Governor +import qualified PlutusLedgerApi.V1.Value as Value +import Plutarch.Api.V1 (mintingPolicySymbol, mkMintingPolicy) +import Agora.Governor.Scripts (governorPolicy, authorityTokenSymbolFromGovernor, authorityTokenFromGovernor, proposalFromGovernor, stakeFromGovernor, governorValidator) +import Agora.Treasury (treasuryValidator) +import Agora.Proposal.Scripts (proposalValidator, proposalPolicy) +import Agora.Stake.Scripts (stakeValidator, stakePolicy) +import qualified Servant.Server as Servant +import Data.Proxy (Proxy(Proxy)) +import qualified Network.Wai.Handler.Warp as Warp +import Data.Function ((&)) +import qualified Network.Wai as Wai +import qualified Network.HTTP.Types as Http +import Prettyprinter (layoutPretty, defaultLayoutOptions, hsep, viaShow, (<+>)) +import Prettyprinter.Render.String (renderString) +import Options (Options(..)) +import Text.Printf (printf) + +-- | Params required for creating script export. +data ScriptParams = ScriptParams + { governorInitialSpend :: TxOutRef + , gtClassRef :: Tagged GTTag AssetClass + , maximumCosigners :: Integer + } + deriving anyclass (Aeson.ToJSON, Aeson.FromJSON) + deriving stock (Show, Eq, GHC.Generic) + +-- | Scripts that get exported. +data AgoraScripts = AgoraScripts + { gitRev :: String + , governorPolicyInfo :: PolicyInfo + , governorValidatorInfo :: ValidatorInfo + , stakePolicyInfo :: PolicyInfo + , stakeValidatorInfo :: ValidatorInfo + , proposalPolicyInfo :: PolicyInfo + , proposalValidatorInfo :: ValidatorInfo + , treasuryValidatorInfo :: ValidatorInfo + , authorityTokenPolicyInfo :: PolicyInfo + } + deriving anyclass (Aeson.ToJSON, Aeson.FromJSON) + deriving stock (Show, Eq, GHC.Generic) + +-- | Servant API type for script generation. +type API = "generate-scripts" :> ReqBody '[JSON] ScriptParams :> Post '[JSON] AgoraScripts + +-- | Run a Warp server that exposes a script generation endpoint. +runServer :: Options -> IO () +runServer options = do + let settings = + Warp.defaultSettings + & Warp.setPort options.port + & Warp.setLogger + ( \req status _maybeFileSize -> + putStrLn . renderString . layoutPretty defaultLayoutOptions $ + hsep + [ "[info]" + , "[" <> "Status:" <+> viaShow (Http.statusCode status) <> "]" + , viaShow $ Wai.requestMethod req + , viaShow $ Wai.rawPathInfo req + ] + ) + + printf "[info] Running 'agora-scripts' on :%d\n" (Warp.getPort settings) + Warp.runSettings settings $ Servant.serve (Proxy @API) (pure . agoraScripts) + +-- | Create scripts from params. +agoraScripts :: ScriptParams -> AgoraScripts +agoraScripts params = + AgoraScripts + { gitRev = revision + , governorPolicyInfo = mkPolicyInfo (governorPolicy governor) + , governorValidatorInfo = mkValidatorInfo (governorValidator governor) + , stakePolicyInfo = mkPolicyInfo (stakePolicy params.gtClassRef) + , stakeValidatorInfo = mkValidatorInfo (stakeValidator stake) + , proposalPolicyInfo = mkPolicyInfo (proposalPolicy governorSTAssetClass) + , proposalValidatorInfo = mkValidatorInfo (proposalValidator proposal) + , treasuryValidatorInfo = mkValidatorInfo (treasuryValidator authorityTokenSymbol) + , authorityTokenPolicyInfo = mkPolicyInfo (authorityTokenPolicy authorityToken) + } + where + revision :: String + revision = $(gitBranch) <> "@" <> $(gitHash) + + governor :: Governor + governor = + Governor + { Governor.gstOutRef = params.governorInitialSpend + , Governor.gtClassRef = params.gtClassRef + , Governor.maximumCosigners = params.maximumCosigners + } + + authorityToken :: AuthorityToken + authorityToken = authorityTokenFromGovernor governor + + authorityTokenSymbol :: CurrencySymbol + authorityTokenSymbol = authorityTokenSymbolFromGovernor governor + + governorSTAssetClass :: AssetClass + governorSTAssetClass = + Value.assetClass (mintingPolicySymbol $ mkMintingPolicy $ governorPolicy governor) "" + + proposal :: Proposal + proposal = proposalFromGovernor governor + + stake :: Stake + stake = stakeFromGovernor governor diff --git a/agora-scripts/Options.hs b/agora-scripts/Options.hs index e56d09a..38f473f 100644 --- a/agora-scripts/Options.hs +++ b/agora-scripts/Options.hs @@ -9,30 +9,23 @@ module Options (Options (..), parseOptions) where import Options.Applicative ((<**>)) import Options.Applicative qualified as Opt +import qualified Network.Wai.Handler.Warp as Warp data Options = Options - { config :: FilePath - , output :: FilePath + { port :: Warp.Port } deriving stock (Show, Eq) opt :: Opt.Parser Options opt = Options - <$> Opt.strOption - ( Opt.long "config" - <> Opt.short 'c' - <> Opt.metavar "CONFIG_PATH" - <> Opt.value "./agora-scripts/agora-params.json" + <$> Opt.option Opt.auto + ( Opt.long "port" + <> Opt.short 'p' + <> Opt.metavar "PORT" + <> Opt.value 3939 <> Opt.help "The path where the script configuration is." ) - <*> Opt.strOption - ( Opt.long "output" - <> Opt.short 'o' - <> Opt.metavar "OUTPUT_PATH" - <> Opt.value "./agora-scripts/agora-scripts.json" - <> Opt.help "Output where generated scripts will be." - ) parseOptions :: IO Options parseOptions = Opt.execParser p diff --git a/agora-scripts/Scripts.hs b/agora-scripts/Scripts.hs index 132f5ce..fd72c4f 100644 --- a/agora-scripts/Scripts.hs +++ b/agora-scripts/Scripts.hs @@ -9,113 +9,11 @@ Export scripts given configuration. -} module Main (main) where -import Agora.AuthorityToken (AuthorityToken, authorityTokenPolicy) -import Agora.Governor (Governor (Governor)) -import Agora.Governor qualified as Governor -import Agora.Governor.Scripts ( - authorityTokenFromGovernor, - authorityTokenSymbolFromGovernor, - governorPolicy, - governorValidator, - proposalFromGovernor, - stakeFromGovernor, - ) -import Agora.Proposal (Proposal) -import Agora.Proposal.Scripts (proposalPolicy, proposalValidator) -import Agora.SafeMoney (GTTag) -import Agora.ScriptInfo (PolicyInfo, ValidatorInfo, mkPolicyInfo, mkValidatorInfo) -import Agora.Stake (Stake) -import Agora.Stake.Scripts (stakePolicy, stakeValidator) -import Agora.Treasury (treasuryValidator) -import Control.Monad ((>=>)) -import Data.Aeson qualified as Aeson -import Data.Tagged (Tagged) -import Development.GitRev (gitBranch, gitHash) -import GHC.Generics qualified as GHC -import Options (Options (..), parseOptions) -import Plutarch.Api.V1 (mintingPolicySymbol, mkMintingPolicy) -import PlutusLedgerApi.V1 (TxOutRef) -import PlutusLedgerApi.V1.Value (AssetClass, CurrencySymbol) -import PlutusLedgerApi.V1.Value qualified as Value -import System.Exit (exitFailure) -import Text.Printf (printf) - --- | Params required for creating script export. -data ScriptParams = ScriptParams - { governorInitialSpend :: TxOutRef - , gtClassRef :: Tagged GTTag AssetClass - , maximumCosigners :: Integer - } - deriving anyclass (Aeson.ToJSON, Aeson.FromJSON) - deriving stock (Show, Eq, GHC.Generic) - --- | Scripts that get exported. -data AgoraScripts = AgoraScripts - { gitRev :: String - , governorPolicyInfo :: PolicyInfo - , governorValidatorInfo :: ValidatorInfo - , stakePolicyInfo :: PolicyInfo - , stakeValidatorInfo :: ValidatorInfo - , proposalPolicyInfo :: PolicyInfo - , proposalValidatorInfo :: ValidatorInfo - , treasuryValidatorInfo :: ValidatorInfo - , authorityTokenPolicyInfo :: PolicyInfo - } - deriving anyclass (Aeson.ToJSON, Aeson.FromJSON) - deriving stock (Show, Eq, GHC.Generic) +import Options (parseOptions) +import API (runServer) main :: IO () main = do options <- parseOptions - params <- - Aeson.eitherDecodeFileStrict @ScriptParams options.config - >>= either (putStrLn >=> const exitFailure) pure - - let scripts = agoraScripts params - - Aeson.encodeFile options.output scripts - - printf "Done! Wrote to %s\n" options.output - --- | Create scripts from params. -agoraScripts :: ScriptParams -> AgoraScripts -agoraScripts params = - AgoraScripts - { gitRev = revision - , governorPolicyInfo = mkPolicyInfo (governorPolicy governor) - , governorValidatorInfo = mkValidatorInfo (governorValidator governor) - , stakePolicyInfo = mkPolicyInfo (stakePolicy params.gtClassRef) - , stakeValidatorInfo = mkValidatorInfo (stakeValidator stake) - , proposalPolicyInfo = mkPolicyInfo (proposalPolicy governorSTAssetClass) - , proposalValidatorInfo = mkValidatorInfo (proposalValidator proposal) - , treasuryValidatorInfo = mkValidatorInfo (treasuryValidator authorityTokenSymbol) - , authorityTokenPolicyInfo = mkPolicyInfo (authorityTokenPolicy authorityToken) - } - where - revision :: String - revision = $(gitBranch) <> "@" <> $(gitHash) - - governor :: Governor - governor = - Governor - { Governor.gstOutRef = params.governorInitialSpend - , Governor.gtClassRef = params.gtClassRef - , Governor.maximumCosigners = params.maximumCosigners - } - - authorityToken :: AuthorityToken - authorityToken = authorityTokenFromGovernor governor - - authorityTokenSymbol :: CurrencySymbol - authorityTokenSymbol = authorityTokenSymbolFromGovernor governor - - governorSTAssetClass :: AssetClass - governorSTAssetClass = - Value.assetClass (mintingPolicySymbol $ mkMintingPolicy $ governorPolicy governor) "" - - proposal :: Proposal - proposal = proposalFromGovernor governor - - stake :: Stake - stake = stakeFromGovernor governor + runServer options diff --git a/agora.cabal b/agora.cabal index 8e8ba53..2e90362 100644 --- a/agora.cabal +++ b/agora.cabal @@ -234,11 +234,19 @@ executable agora-scripts import: lang, deps, exe-opts main-is: Scripts.hs hs-source-dirs: agora-scripts - other-modules: Options + other-modules: + Options + API build-depends: , agora , gitrev , optparse-applicative + , servant + , servant-server + , warp + , wai + , http-types + , prettyprinter executable agora-purescript-bridge import: lang, deps, exe-opts From e862de7e59cd07d626be48457565dcd21c760d98 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Tue, 21 Jun 2022 14:48:31 +0200 Subject: [PATCH 2/9] create initial POC script generating API --- agora-scripts/API.hs | 111 +++++++++++------------ agora-scripts/Cache.hs | 1 + agora-scripts/Codec/Serialise/Orphans.hs | 41 +++++++++ agora-scripts/Data/Cache/Cached.hs | 41 +++++++++ agora-scripts/Options.hs | 5 +- agora-scripts/Scripts.hs | 21 ++--- agora-scripts/Types.hs | 42 +++++++++ agora.cabal | 16 +++- flake.nix | 14 ++- 9 files changed, 210 insertions(+), 82 deletions(-) create mode 100644 agora-scripts/Cache.hs create mode 100644 agora-scripts/Codec/Serialise/Orphans.hs create mode 100644 agora-scripts/Data/Cache/Cached.hs create mode 100644 agora-scripts/Types.hs diff --git a/agora-scripts/API.hs b/agora-scripts/API.hs index bba06a3..499faf8 100644 --- a/agora-scripts/API.hs +++ b/agora-scripts/API.hs @@ -1,68 +1,49 @@ {-# LANGUAGE TemplateHaskell #-} -{- | -Module : API -Maintainer : emi@haskell.fyi -Description: API for script exporter. -API for script exporter. +{- | Module : API + Maintainer : emi@haskell.fyi + Description: API for script exporter. + + API for script exporter. -} +module API ( + AgoraScripts (..), + ScriptParams (..), + API, + agoraScripts, + runServer, +) where -module API (AgoraScripts(..), ScriptParams(..), API, agoraScripts, runServer) where - -import Servant.API (type (:>), ReqBody, JSON, Post) -import PlutusLedgerApi.V1 (TxOutRef) -import Data.Tagged (Tagged) -import Agora.SafeMoney (GTTag) -import PlutusLedgerApi.V1.Value (AssetClass, CurrencySymbol) -import qualified Data.Aeson as Aeson -import qualified GHC.Generics as GHC -import Agora.ScriptInfo (PolicyInfo, ValidatorInfo, mkPolicyInfo, mkValidatorInfo) -import Agora.Stake (Stake(..)) -import Agora.Proposal (Proposal(..)) -import Agora.AuthorityToken (AuthorityToken(..), authorityTokenPolicy) -import Agora.Governor (Governor(..)) -import Development.GitRev (gitBranch, gitHash) -import qualified Agora.Governor as Governor -import qualified PlutusLedgerApi.V1.Value as Value -import Plutarch.Api.V1 (mintingPolicySymbol, mkMintingPolicy) -import Agora.Governor.Scripts (governorPolicy, authorityTokenSymbolFromGovernor, authorityTokenFromGovernor, proposalFromGovernor, stakeFromGovernor, governorValidator) +import Agora.AuthorityToken (AuthorityToken (..), authorityTokenPolicy) +import Agora.Governor (Governor (..)) +import Agora.Governor qualified as Governor +import Agora.Governor.Scripts (authorityTokenFromGovernor, authorityTokenSymbolFromGovernor, governorPolicy, governorValidator, proposalFromGovernor, stakeFromGovernor) +import Agora.Proposal (Proposal (..)) +import Agora.Proposal.Scripts (proposalPolicy, proposalValidator) +import Agora.ScriptInfo (mkPolicyInfo, mkValidatorInfo) +import Agora.Stake (Stake (..)) +import Agora.Stake.Scripts (stakePolicy, stakeValidator) import Agora.Treasury (treasuryValidator) -import Agora.Proposal.Scripts (proposalValidator, proposalPolicy) -import Agora.Stake.Scripts (stakeValidator, stakePolicy) -import qualified Servant.Server as Servant -import Data.Proxy (Proxy(Proxy)) -import qualified Network.Wai.Handler.Warp as Warp +import Codec.Serialise.Orphans () +import Data.Cache.Cached (cachedFor) import Data.Function ((&)) -import qualified Network.Wai as Wai -import qualified Network.HTTP.Types as Http -import Prettyprinter (layoutPretty, defaultLayoutOptions, hsep, viaShow, (<+>)) +import Data.Proxy (Proxy (Proxy)) +import Development.GitRev (gitBranch, gitHash) +import Network.HTTP.Types qualified as Http +import Network.Wai qualified as Wai +import Network.Wai.Handler.Warp qualified as Warp +import Network.Wai.Middleware.Cors (CorsResourcePolicy (corsRequestHeaders), cors, simpleCorsResourcePolicy) +import Options (Options (..)) +import Plutarch.Api.V1 (mintingPolicySymbol, mkMintingPolicy) +import PlutusLedgerApi.V1.Value (AssetClass, CurrencySymbol) +import PlutusLedgerApi.V1.Value qualified as Value +import Prettyprinter (defaultLayoutOptions, hsep, layoutPretty, viaShow, (<+>)) import Prettyprinter.Render.String (renderString) -import Options (Options(..)) +import Servant.API (JSON, Post, ReqBody, type (:>)) +import Servant.Server qualified as Servant +import System.Clock (TimeSpec (TimeSpec)) import Text.Printf (printf) - --- | Params required for creating script export. -data ScriptParams = ScriptParams - { governorInitialSpend :: TxOutRef - , gtClassRef :: Tagged GTTag AssetClass - , maximumCosigners :: Integer - } - deriving anyclass (Aeson.ToJSON, Aeson.FromJSON) - deriving stock (Show, Eq, GHC.Generic) - --- | Scripts that get exported. -data AgoraScripts = AgoraScripts - { gitRev :: String - , governorPolicyInfo :: PolicyInfo - , governorValidatorInfo :: ValidatorInfo - , stakePolicyInfo :: PolicyInfo - , stakeValidatorInfo :: ValidatorInfo - , proposalPolicyInfo :: PolicyInfo - , proposalValidatorInfo :: ValidatorInfo - , treasuryValidatorInfo :: ValidatorInfo - , authorityTokenPolicyInfo :: PolicyInfo - } - deriving anyclass (Aeson.ToJSON, Aeson.FromJSON) - deriving stock (Show, Eq, GHC.Generic) +import Types (AgoraScripts (..), ScriptParams (..)) -- | Servant API type for script generation. type API = "generate-scripts" :> ReqBody '[JSON] ScriptParams :> Post '[JSON] AgoraScripts @@ -84,8 +65,20 @@ runServer options = do ] ) + corsPolicy = + simpleCorsResourcePolicy + { -- NOTE: Webpack dev server requires this for CORS workaround. + corsRequestHeaders = "content-type" : corsRequestHeaders simpleCorsResourcePolicy + } + corsMiddleware = cors . const $ Just corsPolicy + + -- Scripts stay cached for five minutes + agoraScripts' <- cachedFor (Just $ TimeSpec 300 0) agoraScripts + printf "[info] Running 'agora-scripts' on :%d\n" (Warp.getPort settings) - Warp.runSettings settings $ Servant.serve (Proxy @API) (pure . agoraScripts) + Servant.serve (Proxy @API) agoraScripts' + & corsMiddleware + & Warp.runSettings settings -- | Create scripts from params. agoraScripts :: ScriptParams -> AgoraScripts @@ -102,6 +95,8 @@ agoraScripts params = , authorityTokenPolicyInfo = mkPolicyInfo (authorityTokenPolicy authorityToken) } where + -- This encodes the git revision of the server. It's useful for the caller + -- to be able to ensure they are compatible with it. revision :: String revision = $(gitBranch) <> "@" <> $(gitHash) diff --git a/agora-scripts/Cache.hs b/agora-scripts/Cache.hs new file mode 100644 index 0000000..bfbad91 --- /dev/null +++ b/agora-scripts/Cache.hs @@ -0,0 +1 @@ +module Cache where diff --git a/agora-scripts/Codec/Serialise/Orphans.hs b/agora-scripts/Codec/Serialise/Orphans.hs new file mode 100644 index 0000000..62d69bf --- /dev/null +++ b/agora-scripts/Codec/Serialise/Orphans.hs @@ -0,0 +1,41 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +{- | +Module : Codec.Serialise.Orphans +Maintainer : emi@haskell.fyi +Description: Orphan instances for Serialising and Hashing Cardano types. + +Orphan instances for Serialising and Hashing Cardano types. +-} +module Codec.Serialise.Orphans () where + +import Codec.Serialise (Serialise, serialise) +import Data.Hashable (Hashable (hashWithSalt)) +import Data.Tagged (Tagged (Tagged)) +import PlutusLedgerApi.V1 (TxId, TxOutRef) +import PlutusLedgerApi.V1.Value (AssetClass, CurrencySymbol, TokenName) +import Types (ScriptParams) + +deriving anyclass instance + Serialise TxOutRef + +deriving anyclass instance + Serialise TxId + +deriving anyclass instance + Serialise AssetClass + +deriving anyclass instance + Serialise CurrencySymbol + +deriving anyclass instance + Serialise TokenName + +deriving newtype instance + Serialise a => + Serialise (Tagged s a) + +deriving anyclass instance Serialise ScriptParams + +instance Hashable ScriptParams where + hashWithSalt s scriptParams = hashWithSalt s (serialise scriptParams) diff --git a/agora-scripts/Data/Cache/Cached.hs b/agora-scripts/Data/Cache/Cached.hs new file mode 100644 index 0000000..0b1acb5 --- /dev/null +++ b/agora-scripts/Data/Cache/Cached.hs @@ -0,0 +1,41 @@ +{- | Module : API + Maintainer : emi@haskell.fyi + Description: API for script exporter. + + API for script exporter. +-} +module Data.Cache.Cached ( + cached, + cachedFor, +) where + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Cache qualified as Cache +import Data.Functor ((<&>)) +import Data.Hashable (Hashable) +import System.Clock (TimeSpec) + +{- | 'cachedFor' but items last forever. + + Uses a HashMap under the hood. +-} +cached :: (Monad m, MonadIO m, Hashable k, Ord k) => (k -> v) -> IO (k -> m v) +cached = cachedFor Nothing + +{- | Create a cached version of a function tainting result with MonadIO context. + + Results are cached dependent on the first argument, @'Maybe' 'TimeSpec'@. + + Uses a HashMap under the hood. +-} +cachedFor :: (Monad m, MonadIO m, Hashable k, Ord k) => Maybe TimeSpec -> (k -> v) -> IO (k -> m v) +cachedFor t f = + Cache.newCache t <&> \cache k -> do + res <- liftIO $ Cache.lookup cache k + case res of + Nothing -> do + let v = f k + liftIO $ Cache.insert cache k v + pure v + Just v -> do + pure v diff --git a/agora-scripts/Options.hs b/agora-scripts/Options.hs index 38f473f..4187a1d 100644 --- a/agora-scripts/Options.hs +++ b/agora-scripts/Options.hs @@ -7,9 +7,9 @@ Command line options for 'agora-scripts'. -} module Options (Options (..), parseOptions) where +import Network.Wai.Handler.Warp qualified as Warp import Options.Applicative ((<**>)) import Options.Applicative qualified as Opt -import qualified Network.Wai.Handler.Warp as Warp data Options = Options { port :: Warp.Port @@ -19,7 +19,8 @@ data Options = Options opt :: Opt.Parser Options opt = Options - <$> Opt.option Opt.auto + <$> Opt.option + Opt.auto ( Opt.long "port" <> Opt.short 'p' <> Opt.metavar "PORT" diff --git a/agora-scripts/Scripts.hs b/agora-scripts/Scripts.hs index fd72c4f..a665c96 100644 --- a/agora-scripts/Scripts.hs +++ b/agora-scripts/Scripts.hs @@ -1,19 +1,14 @@ -{-# LANGUAGE TemplateHaskell #-} +{- | Module : Scripts + Maintainer : emi@haskell.fyi + Description: Export scripts given configuration. -{- | -Module : Scripts -Maintainer : emi@haskell.fyi -Description: Export scripts given configuration. - -Export scripts given configuration. + Export scripts given configuration. -} -module Main (main) where +module Scripts (main) where -import Options (parseOptions) import API (runServer) +import Options (parseOptions) main :: IO () -main = do - options <- parseOptions - - runServer options +main = + parseOptions >>= runServer diff --git a/agora-scripts/Types.hs b/agora-scripts/Types.hs new file mode 100644 index 0000000..db32cf6 --- /dev/null +++ b/agora-scripts/Types.hs @@ -0,0 +1,42 @@ +{- | +Module : Types +Maintainer : emi@haskell.fyi +Description: Param and script types for generation. + +Param and script types for generation. +-} +module Types (ScriptParams (..), AgoraScripts (..)) where + +import Agora.SafeMoney (GTTag) +import Agora.ScriptInfo (PolicyInfo, ValidatorInfo) +import Data.Aeson qualified as Aeson +import Data.Tagged (Tagged) +import GHC.Generics qualified as GHC +import PlutusLedgerApi.V1 (TxOutRef) +import PlutusLedgerApi.V1.Value (AssetClass) + +-- | Params required for creating script export. +data ScriptParams where + ScriptParams :: + { governorInitialSpend :: TxOutRef + , gtClassRef :: Tagged GTTag AssetClass + , maximumCosigners :: Integer + } -> + ScriptParams + deriving anyclass (Aeson.ToJSON, Aeson.FromJSON) + deriving stock (Show, Eq, GHC.Generic, Ord) + +-- | Scripts that get exported. +data AgoraScripts = AgoraScripts + { gitRev :: String + , governorPolicyInfo :: PolicyInfo + , governorValidatorInfo :: ValidatorInfo + , stakePolicyInfo :: PolicyInfo + , stakeValidatorInfo :: ValidatorInfo + , proposalPolicyInfo :: PolicyInfo + , proposalValidatorInfo :: ValidatorInfo + , treasuryValidatorInfo :: ValidatorInfo + , authorityTokenPolicyInfo :: PolicyInfo + } + deriving anyclass (Aeson.ToJSON, Aeson.FromJSON) + deriving stock (Show, Eq, GHC.Generic) diff --git a/agora.cabal b/agora.cabal index 2e90362..4bcf4b5 100644 --- a/agora.cabal +++ b/agora.cabal @@ -235,18 +235,26 @@ executable agora-scripts main-is: Scripts.hs hs-source-dirs: agora-scripts other-modules: - Options API + Codec.Serialise.Orphans + Data.Cache.Cached + Options + Types + build-depends: , agora + , cache + , clock , gitrev + , hashable + , http-types , optparse-applicative + , prettyprinter , servant , servant-server - , warp , wai - , http-types - , prettyprinter + , wai-cors + , warp executable agora-purescript-bridge import: lang, deps, exe-opts diff --git a/flake.nix b/flake.nix index 15ef898..a6d06bf 100644 --- a/flake.nix +++ b/flake.nix @@ -140,11 +140,15 @@ ); applyDep = pkgs: o: - let h = myhackage pkgs.system o.compiler-nix-name; in - (plutarch.applyPlutarchDep pkgs o) // { - modules = haskellModules ++ [ h.module ] ++ (o.modules or [ ]); - extra-hackages = [ (import h.hackageNix) ] ++ (o.extra-hackages or [ ]); - extra-hackage-tarballs = { _xNJUd_plutarch-hackage = h.hackageTarball; } // (o.extra-hackage-tarballs or { }); + let + h = myhackage pkgs.system o.compiler-nix-name; + o' = (plutarch.applyPlutarchDep pkgs o); + in + o' // rec { + modules = haskellModules ++ [ h.module ] ++ (o'.modules or [ ]); + extra-hackages = [ (import h.hackageNix) ] ++ (o'.extra-hackages or [ ]); + extra-hackage-tarballs = { _xNJUd_plutarch-hackage = h.hackageTarball; }; + cabalProjectLocal = (o'.cabalProjectLocal or "") + " , cache >= 0.1.3.0"; }; projectForGhc = compiler-nix-name: system: From 5f2d191ae70dabbaadf4e28889bd1c50cfebc7c8 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Tue, 21 Jun 2022 20:53:20 +0200 Subject: [PATCH 3/9] add granular script querying support --- agora-scripts/API.hs | 27 ++++++++++++++++++---- agora-scripts/Types.hs | 44 +++++++++++++++++++++++++++++++++++- agora.cabal | 2 ++ agora/Agora/Aeson/Orphans.hs | 9 ++++++++ agora/Agora/ScriptInfo.hs | 14 ++++++++++-- 5 files changed, 89 insertions(+), 7 deletions(-) diff --git a/agora-scripts/API.hs b/agora-scripts/API.hs index 499faf8..efccc4e 100644 --- a/agora-scripts/API.hs +++ b/agora-scripts/API.hs @@ -25,7 +25,9 @@ import Agora.Stake (Stake (..)) import Agora.Stake.Scripts (stakePolicy, stakeValidator) import Agora.Treasury (treasuryValidator) import Codec.Serialise.Orphans () +import Data.Aeson qualified as Aeson import Data.Cache.Cached (cachedFor) +import Data.Default.Class (Default (def)) import Data.Function ((&)) import Data.Proxy (Proxy (Proxy)) import Development.GitRev (gitBranch, gitHash) @@ -39,14 +41,16 @@ import PlutusLedgerApi.V1.Value (AssetClass, CurrencySymbol) import PlutusLedgerApi.V1.Value qualified as Value import Prettyprinter (defaultLayoutOptions, hsep, layoutPretty, viaShow, (<+>)) import Prettyprinter.Render.String (renderString) -import Servant.API (JSON, Post, ReqBody, type (:>)) +import Servant.API (JSON, Post, ReqBody, (:<|>) (..), type (:>)) import Servant.Server qualified as Servant import System.Clock (TimeSpec (TimeSpec)) import Text.Printf (printf) -import Types (AgoraScripts (..), ScriptParams (..)) +import Types (AgoraScripts (..), Builders, ScriptParams (..), ScriptQuery, insertBuilder, runQuery) -- | Servant API type for script generation. -type API = "generate-scripts" :> ReqBody '[JSON] ScriptParams :> Post '[JSON] AgoraScripts +type API = + "generate-scripts" :> ReqBody '[JSON] ScriptParams :> Post '[JSON] AgoraScripts + :<|> "query-script" :> ReqBody '[JSON] ScriptQuery :> Post '[JSON] Aeson.Value -- | Run a Warp server that exposes a script generation endpoint. runServer :: Options -> IO () @@ -74,12 +78,27 @@ runServer options = do -- Scripts stay cached for five minutes agoraScripts' <- cachedFor (Just $ TimeSpec 300 0) agoraScripts + query <- cachedFor (Just $ TimeSpec 300 0) (`runQuery` agoraBuilders) printf "[info] Running 'agora-scripts' on :%d\n" (Warp.getPort settings) - Servant.serve (Proxy @API) agoraScripts' + Servant.serve + (Proxy @API) + (agoraScripts' :<|> query) & corsMiddleware & Warp.runSettings settings +agoraBuilders :: Builders +agoraBuilders = + def + & insertBuilder "governorPolicy" ((.governorPolicyInfo) . agoraScripts) + & insertBuilder "governorValidator" ((.governorValidatorInfo) . agoraScripts) + & insertBuilder "stakePolicyInfo" ((.stakePolicyInfo) . agoraScripts) + & insertBuilder "stakeValidatorInfo" ((.stakeValidatorInfo) . agoraScripts) + & insertBuilder "proposalPolicyInfo" ((.proposalPolicyInfo) . agoraScripts) + & insertBuilder "proposalValidatorInfo" ((.proposalValidatorInfo) . agoraScripts) + & insertBuilder "treasuryValidatorInfo" ((.treasuryValidatorInfo) . agoraScripts) + & insertBuilder "authorityTokenPolicyInfo" ((.authorityTokenPolicyInfo) . agoraScripts) + -- | Create scripts from params. agoraScripts :: ScriptParams -> AgoraScripts agoraScripts params = diff --git a/agora-scripts/Types.hs b/agora-scripts/Types.hs index db32cf6..7a36404 100644 --- a/agora-scripts/Types.hs +++ b/agora-scripts/Types.hs @@ -5,12 +5,26 @@ Description: Param and script types for generation. Param and script types for generation. -} -module Types (ScriptParams (..), AgoraScripts (..)) where +module Types ( + ScriptParams (..), + AgoraScripts (..), + ScriptQuery (..), + Builders (..), + throughJSON, + runQuery, + insertBuilder, +) where import Agora.SafeMoney (GTTag) import Agora.ScriptInfo (PolicyInfo, ValidatorInfo) import Data.Aeson qualified as Aeson +import Data.Coerce (coerce) +import Data.Default.Class (Default (def)) +import Data.Hashable (Hashable) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map import Data.Tagged (Tagged) +import Data.Text (Text) import GHC.Generics qualified as GHC import PlutusLedgerApi.V1 (TxOutRef) import PlutusLedgerApi.V1.Value (AssetClass) @@ -40,3 +54,31 @@ data AgoraScripts = AgoraScripts } deriving anyclass (Aeson.ToJSON, Aeson.FromJSON) deriving stock (Show, Eq, GHC.Generic) + +data ScriptQuery = ScriptQuery + { name :: Text + , paramsPayload :: Aeson.Value + } + deriving anyclass (Aeson.ToJSON, Aeson.FromJSON) + deriving stock (Show, Eq, GHC.Generic, Ord) + deriving anyclass (Hashable) + +-- | Run a query on Builders. +runQuery :: ScriptQuery -> Builders -> Aeson.Value +runQuery s (Builders b) = + maybe Aeson.Null ($ s.paramsPayload) (Map.lookup s.name b) + +throughJSON :: (Aeson.FromJSON p, Aeson.ToJSON s) => (p -> s) -> (Aeson.Value -> Aeson.Value) +throughJSON f = Aeson.toJSON . \case { Aeson.Error _ -> Nothing; Aeson.Success v -> Just (f v) } . Aeson.fromJSON + +-- | Represents a list of named pure functions. +newtype Builders = Builders + { getBuilders :: Map Text (Aeson.Value -> Aeson.Value) + } + +instance Default Builders where + def = Builders Map.empty + +-- | Insert a pure function into the Builders map. +insertBuilder :: (Aeson.FromJSON p, Aeson.ToJSON s) => Text -> (p -> s) -> Builders -> Builders +insertBuilder k = coerce . Map.insert k . throughJSON diff --git a/agora.cabal b/agora.cabal index 4bcf4b5..8dd8e27 100644 --- a/agora.cabal +++ b/agora.cabal @@ -28,6 +28,7 @@ common lang BinaryLiterals ConstrainedClassMethods ConstraintKinds + DuplicateRecordFields DataKinds DeriveAnyClass DeriveDataTypeable @@ -255,6 +256,7 @@ executable agora-scripts , wai , wai-cors , warp + , containers executable agora-purescript-bridge import: lang, deps, exe-opts diff --git a/agora/Agora/Aeson/Orphans.hs b/agora/Agora/Aeson/Orphans.hs index 75ff1af..6c14c62 100644 --- a/agora/Agora/Aeson/Orphans.hs +++ b/agora/Agora/Aeson/Orphans.hs @@ -109,6 +109,15 @@ deriving via instance (Aeson.FromJSON Plutus.ValidatorHash) +deriving via + (AsBase16Bytes Plutus.BuiltinByteString) + instance + (Aeson.ToJSON Plutus.BuiltinByteString) +deriving via + (AsBase16Bytes Plutus.BuiltinByteString) + instance + (Aeson.FromJSON Plutus.BuiltinByteString) + deriving via (AsBase16Codec Plutus.Validator) instance diff --git a/agora/Agora/ScriptInfo.hs b/agora/Agora/ScriptInfo.hs index 09c7ac6..4942654 100644 --- a/agora/Agora/ScriptInfo.hs +++ b/agora/Agora/ScriptInfo.hs @@ -9,6 +9,7 @@ module Agora.ScriptInfo ( -- * Types PolicyInfo (..), ValidatorInfo (..), + ScriptInfo (..), -- * Introduction functions mkValidatorInfo, @@ -19,8 +20,17 @@ import Agora.Aeson.Orphans () import Data.Aeson qualified as Aeson import GHC.Generics qualified as GHC import Plutarch.Api.V1 (PMintingPolicy, PValidator, mintingPolicySymbol, mkMintingPolicy, mkValidator, validatorHash) -import PlutusLedgerApi.V1 (MintingPolicy, Validator, ValidatorHash) -import PlutusLedgerApi.V1.Value (CurrencySymbol) +import PlutusLedgerApi.V1 (BuiltinByteString, CurrencySymbol (unCurrencySymbol), MintingPolicy, Script, Validator, ValidatorHash, unMintingPolicyScript) + +-- | Bundle containing a 'Script' and its hash. +data ScriptInfo = ScriptInfo + { script :: Script + -- ^ The validator script. + , hash :: BuiltinByteString + -- ^ Hash of the script. + } + deriving stock (Show, Eq, GHC.Generic) + deriving anyclass (Aeson.ToJSON, Aeson.FromJSON) {- | Bundle containing a 'Validator' and its hash. From 74669018753b970ab08d6512eef8dd27da23aebb Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Thu, 23 Jun 2022 15:05:35 +0200 Subject: [PATCH 4/9] format and fix Werror compile error --- agora-scripts/Cache.hs | 1 - agora-scripts/Options.hs | 2 +- agora.cabal | 19 +++++++++---------- agora/Agora/ScriptInfo.hs | 9 ++++++++- 4 files changed, 18 insertions(+), 13 deletions(-) delete mode 100644 agora-scripts/Cache.hs diff --git a/agora-scripts/Cache.hs b/agora-scripts/Cache.hs deleted file mode 100644 index bfbad91..0000000 --- a/agora-scripts/Cache.hs +++ /dev/null @@ -1 +0,0 @@ -module Cache where diff --git a/agora-scripts/Options.hs b/agora-scripts/Options.hs index 4187a1d..b0fa855 100644 --- a/agora-scripts/Options.hs +++ b/agora-scripts/Options.hs @@ -11,7 +11,7 @@ import Network.Wai.Handler.Warp qualified as Warp import Options.Applicative ((<**>)) import Options.Applicative qualified as Opt -data Options = Options +newtype Options = Options { port :: Warp.Port } deriving stock (Show, Eq) diff --git a/agora.cabal b/agora.cabal index 8dd8e27..83d3189 100644 --- a/agora.cabal +++ b/agora.cabal @@ -12,11 +12,11 @@ license: Apache-2.0 common lang ghc-options: - -Wall -Wcompat -Wincomplete-uni-patterns -Wno-unused-do-bind - -Wno-partial-type-signatures -Wmissing-export-lists - -Wincomplete-record-updates -Wmissing-deriving-strategies - -Wno-name-shadowing -Wunused-foralls -fprint-explicit-foralls - -fprint-explicit-kinds -Werror + -Werror -Wall -Wcompat -Wincomplete-uni-patterns + -Wno-unused-do-bind -Wno-partial-type-signatures + -Wmissing-export-lists -Wincomplete-record-updates + -Wmissing-deriving-strategies -Wno-name-shadowing -Wunused-foralls + -fprint-explicit-foralls -fprint-explicit-kinds mixins: base hiding (Prelude), @@ -28,7 +28,6 @@ common lang BinaryLiterals ConstrainedClassMethods ConstraintKinds - DuplicateRecordFields DataKinds DeriveAnyClass DeriveDataTypeable @@ -40,6 +39,7 @@ common lang DerivingStrategies DerivingVia DoAndIfThenElse + DuplicateRecordFields EmptyCase EmptyDataDecls EmptyDataDeriving @@ -138,6 +138,7 @@ common exe-opts library import: lang, deps exposed-modules: + Agora.Aeson.Orphans Agora.AuthorityToken Agora.Effect Agora.Effect.GovernorMutation @@ -146,6 +147,7 @@ library Agora.Governor Agora.Governor.Scripts Agora.MultiSig + Agora.Plutarch.Orphans Agora.Proposal Agora.Proposal.Scripts Agora.Proposal.Time @@ -157,9 +159,6 @@ library Agora.Utils other-modules: - Agora.Aeson.Orphans - Agora.Plutarch.Orphans - hs-source-dirs: agora library pprelude @@ -246,6 +245,7 @@ executable agora-scripts , agora , cache , clock + , containers , gitrev , hashable , http-types @@ -256,7 +256,6 @@ executable agora-scripts , wai , wai-cors , warp - , containers executable agora-purescript-bridge import: lang, deps, exe-opts diff --git a/agora/Agora/ScriptInfo.hs b/agora/Agora/ScriptInfo.hs index 4942654..698c9c5 100644 --- a/agora/Agora/ScriptInfo.hs +++ b/agora/Agora/ScriptInfo.hs @@ -20,7 +20,14 @@ import Agora.Aeson.Orphans () import Data.Aeson qualified as Aeson import GHC.Generics qualified as GHC import Plutarch.Api.V1 (PMintingPolicy, PValidator, mintingPolicySymbol, mkMintingPolicy, mkValidator, validatorHash) -import PlutusLedgerApi.V1 (BuiltinByteString, CurrencySymbol (unCurrencySymbol), MintingPolicy, Script, Validator, ValidatorHash, unMintingPolicyScript) +import PlutusLedgerApi.V1 ( + BuiltinByteString, + CurrencySymbol, + MintingPolicy, + Script, + Validator, + ValidatorHash, + ) -- | Bundle containing a 'Script' and its hash. data ScriptInfo = ScriptInfo From a5765a355d08b3af1155a30163dc5fec3923b03b Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Thu, 23 Jun 2022 19:54:34 +0200 Subject: [PATCH 5/9] restructure `agora-scripts` modules In order to allow reusing this code in the future, I've made it so that Agora-specific code all lives in `Main`, and everything else lives in `ScriptExport` or other non-Agora modules. --- agora-scripts/API.hs | 144 -------------------- agora-scripts/Codec/Serialise/Orphans.hs | 9 +- agora-scripts/Main.hs | 144 ++++++++++++++++++++ agora-scripts/ScriptExport/API.hs | 100 ++++++++++++++ agora-scripts/{ => ScriptExport}/Options.hs | 4 +- agora-scripts/ScriptExport/Types.hs | 94 +++++++++++++ agora-scripts/Scripts.hs | 14 -- agora-scripts/Types.hs | 84 ------------ agora-scripts/agora-params.json | 11 -- agora.cabal | 8 +- 10 files changed, 345 insertions(+), 267 deletions(-) delete mode 100644 agora-scripts/API.hs create mode 100644 agora-scripts/Main.hs create mode 100644 agora-scripts/ScriptExport/API.hs rename agora-scripts/{ => ScriptExport}/Options.hs (89%) create mode 100644 agora-scripts/ScriptExport/Types.hs delete mode 100644 agora-scripts/Scripts.hs delete mode 100644 agora-scripts/Types.hs delete mode 100644 agora-scripts/agora-params.json diff --git a/agora-scripts/API.hs b/agora-scripts/API.hs deleted file mode 100644 index efccc4e..0000000 --- a/agora-scripts/API.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -{- | Module : API - Maintainer : emi@haskell.fyi - Description: API for script exporter. - - API for script exporter. --} -module API ( - AgoraScripts (..), - ScriptParams (..), - API, - agoraScripts, - runServer, -) where - -import Agora.AuthorityToken (AuthorityToken (..), authorityTokenPolicy) -import Agora.Governor (Governor (..)) -import Agora.Governor qualified as Governor -import Agora.Governor.Scripts (authorityTokenFromGovernor, authorityTokenSymbolFromGovernor, governorPolicy, governorValidator, proposalFromGovernor, stakeFromGovernor) -import Agora.Proposal (Proposal (..)) -import Agora.Proposal.Scripts (proposalPolicy, proposalValidator) -import Agora.ScriptInfo (mkPolicyInfo, mkValidatorInfo) -import Agora.Stake (Stake (..)) -import Agora.Stake.Scripts (stakePolicy, stakeValidator) -import Agora.Treasury (treasuryValidator) -import Codec.Serialise.Orphans () -import Data.Aeson qualified as Aeson -import Data.Cache.Cached (cachedFor) -import Data.Default.Class (Default (def)) -import Data.Function ((&)) -import Data.Proxy (Proxy (Proxy)) -import Development.GitRev (gitBranch, gitHash) -import Network.HTTP.Types qualified as Http -import Network.Wai qualified as Wai -import Network.Wai.Handler.Warp qualified as Warp -import Network.Wai.Middleware.Cors (CorsResourcePolicy (corsRequestHeaders), cors, simpleCorsResourcePolicy) -import Options (Options (..)) -import Plutarch.Api.V1 (mintingPolicySymbol, mkMintingPolicy) -import PlutusLedgerApi.V1.Value (AssetClass, CurrencySymbol) -import PlutusLedgerApi.V1.Value qualified as Value -import Prettyprinter (defaultLayoutOptions, hsep, layoutPretty, viaShow, (<+>)) -import Prettyprinter.Render.String (renderString) -import Servant.API (JSON, Post, ReqBody, (:<|>) (..), type (:>)) -import Servant.Server qualified as Servant -import System.Clock (TimeSpec (TimeSpec)) -import Text.Printf (printf) -import Types (AgoraScripts (..), Builders, ScriptParams (..), ScriptQuery, insertBuilder, runQuery) - --- | Servant API type for script generation. -type API = - "generate-scripts" :> ReqBody '[JSON] ScriptParams :> Post '[JSON] AgoraScripts - :<|> "query-script" :> ReqBody '[JSON] ScriptQuery :> Post '[JSON] Aeson.Value - --- | Run a Warp server that exposes a script generation endpoint. -runServer :: Options -> IO () -runServer options = do - let settings = - Warp.defaultSettings - & Warp.setPort options.port - & Warp.setLogger - ( \req status _maybeFileSize -> - putStrLn . renderString . layoutPretty defaultLayoutOptions $ - hsep - [ "[info]" - , "[" <> "Status:" <+> viaShow (Http.statusCode status) <> "]" - , viaShow $ Wai.requestMethod req - , viaShow $ Wai.rawPathInfo req - ] - ) - - corsPolicy = - simpleCorsResourcePolicy - { -- NOTE: Webpack dev server requires this for CORS workaround. - corsRequestHeaders = "content-type" : corsRequestHeaders simpleCorsResourcePolicy - } - corsMiddleware = cors . const $ Just corsPolicy - - -- Scripts stay cached for five minutes - agoraScripts' <- cachedFor (Just $ TimeSpec 300 0) agoraScripts - query <- cachedFor (Just $ TimeSpec 300 0) (`runQuery` agoraBuilders) - - printf "[info] Running 'agora-scripts' on :%d\n" (Warp.getPort settings) - Servant.serve - (Proxy @API) - (agoraScripts' :<|> query) - & corsMiddleware - & Warp.runSettings settings - -agoraBuilders :: Builders -agoraBuilders = - def - & insertBuilder "governorPolicy" ((.governorPolicyInfo) . agoraScripts) - & insertBuilder "governorValidator" ((.governorValidatorInfo) . agoraScripts) - & insertBuilder "stakePolicyInfo" ((.stakePolicyInfo) . agoraScripts) - & insertBuilder "stakeValidatorInfo" ((.stakeValidatorInfo) . agoraScripts) - & insertBuilder "proposalPolicyInfo" ((.proposalPolicyInfo) . agoraScripts) - & insertBuilder "proposalValidatorInfo" ((.proposalValidatorInfo) . agoraScripts) - & insertBuilder "treasuryValidatorInfo" ((.treasuryValidatorInfo) . agoraScripts) - & insertBuilder "authorityTokenPolicyInfo" ((.authorityTokenPolicyInfo) . agoraScripts) - --- | Create scripts from params. -agoraScripts :: ScriptParams -> AgoraScripts -agoraScripts params = - AgoraScripts - { gitRev = revision - , governorPolicyInfo = mkPolicyInfo (governorPolicy governor) - , governorValidatorInfo = mkValidatorInfo (governorValidator governor) - , stakePolicyInfo = mkPolicyInfo (stakePolicy params.gtClassRef) - , stakeValidatorInfo = mkValidatorInfo (stakeValidator stake) - , proposalPolicyInfo = mkPolicyInfo (proposalPolicy governorSTAssetClass) - , proposalValidatorInfo = mkValidatorInfo (proposalValidator proposal) - , treasuryValidatorInfo = mkValidatorInfo (treasuryValidator authorityTokenSymbol) - , authorityTokenPolicyInfo = mkPolicyInfo (authorityTokenPolicy authorityToken) - } - where - -- This encodes the git revision of the server. It's useful for the caller - -- to be able to ensure they are compatible with it. - revision :: String - revision = $(gitBranch) <> "@" <> $(gitHash) - - governor :: Governor - governor = - Governor - { Governor.gstOutRef = params.governorInitialSpend - , Governor.gtClassRef = params.gtClassRef - , Governor.maximumCosigners = params.maximumCosigners - } - - authorityToken :: AuthorityToken - authorityToken = authorityTokenFromGovernor governor - - authorityTokenSymbol :: CurrencySymbol - authorityTokenSymbol = authorityTokenSymbolFromGovernor governor - - governorSTAssetClass :: AssetClass - governorSTAssetClass = - Value.assetClass (mintingPolicySymbol $ mkMintingPolicy $ governorPolicy governor) "" - - proposal :: Proposal - proposal = proposalFromGovernor governor - - stake :: Stake - stake = stakeFromGovernor governor diff --git a/agora-scripts/Codec/Serialise/Orphans.hs b/agora-scripts/Codec/Serialise/Orphans.hs index 62d69bf..f310abd 100644 --- a/agora-scripts/Codec/Serialise/Orphans.hs +++ b/agora-scripts/Codec/Serialise/Orphans.hs @@ -9,12 +9,10 @@ Orphan instances for Serialising and Hashing Cardano types. -} module Codec.Serialise.Orphans () where -import Codec.Serialise (Serialise, serialise) -import Data.Hashable (Hashable (hashWithSalt)) +import Codec.Serialise (Serialise) import Data.Tagged (Tagged (Tagged)) import PlutusLedgerApi.V1 (TxId, TxOutRef) import PlutusLedgerApi.V1.Value (AssetClass, CurrencySymbol, TokenName) -import Types (ScriptParams) deriving anyclass instance Serialise TxOutRef @@ -34,8 +32,3 @@ deriving anyclass instance deriving newtype instance Serialise a => Serialise (Tagged s a) - -deriving anyclass instance Serialise ScriptParams - -instance Hashable ScriptParams where - hashWithSalt s scriptParams = hashWithSalt s (serialise scriptParams) diff --git a/agora-scripts/Main.hs b/agora-scripts/Main.hs new file mode 100644 index 0000000..3bb85a1 --- /dev/null +++ b/agora-scripts/Main.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE TemplateHaskell #-} + +{- | Module : Main + Maintainer : emi@haskell.fyi + Description: Export scripts given configuration. + + Export scripts given configuration. +-} +module Main (main) where + +import Agora.AuthorityToken (AuthorityToken, authorityTokenPolicy) +import Agora.Governor (Governor (Governor)) +import Agora.Governor qualified as Governor +import Agora.Governor.Scripts (authorityTokenFromGovernor, authorityTokenSymbolFromGovernor, governorPolicy, governorValidator, proposalFromGovernor, stakeFromGovernor) +import Agora.Proposal (Proposal) +import Agora.Proposal.Scripts (proposalPolicy, proposalValidator) +import Agora.SafeMoney (GTTag) +import Agora.ScriptInfo (PolicyInfo, ValidatorInfo, mkPolicyInfo, mkValidatorInfo) +import Agora.Stake (Stake) +import Agora.Stake.Scripts (stakePolicy, stakeValidator) +import Agora.Treasury (treasuryValidator) +import Data.Aeson qualified as Aeson +import Data.Default (def) +import Data.Function ((&)) +import Data.Tagged (Tagged) +import Data.Text (Text) +import Development.GitRev (gitBranch, gitHash) +import GHC.Generics qualified as GHC +import Plutarch.Api.V1 (mintingPolicySymbol, mkMintingPolicy) +import PlutusLedgerApi.V1 (TxOutRef) +import PlutusLedgerApi.V1.Value (AssetClass, CurrencySymbol) +import PlutusLedgerApi.V1.Value qualified as Value +import ScriptExport.API (runServer) +import ScriptExport.Options (parseOptions) +import ScriptExport.Types (Builders, insertBuilder) + +main :: IO () +main = + parseOptions >>= runServer revision builders + where + -- This encodes the git revision of the server. It's useful for the caller + -- to be able to ensure they are compatible with it. + revision :: Text + revision = $(gitBranch) <> "@" <> $(gitHash) + +{- | Builders for Agora scripts. + + @since 0.2.0 +-} +builders :: Builders +builders = + def + & insertBuilder "governorPolicy" ((.governorPolicyInfo) . agoraScripts) + & insertBuilder "governorValidator" ((.governorValidatorInfo) . agoraScripts) + & insertBuilder "stakePolicyInfo" ((.stakePolicyInfo) . agoraScripts) + & insertBuilder "stakeValidatorInfo" ((.stakeValidatorInfo) . agoraScripts) + & insertBuilder "proposalPolicyInfo" ((.proposalPolicyInfo) . agoraScripts) + & insertBuilder "proposalValidatorInfo" ((.proposalValidatorInfo) . agoraScripts) + & insertBuilder "treasuryValidatorInfo" ((.treasuryValidatorInfo) . agoraScripts) + & insertBuilder "authorityTokenPolicyInfo" ((.authorityTokenPolicyInfo) . agoraScripts) + +{- | Create scripts from params. + + @since 0.2.0 +-} +agoraScripts :: ScriptParams -> AgoraScripts +agoraScripts params = + AgoraScripts + { governorPolicyInfo = mkPolicyInfo (governorPolicy governor) + , governorValidatorInfo = mkValidatorInfo (governorValidator governor) + , stakePolicyInfo = mkPolicyInfo (stakePolicy params.gtClassRef) + , stakeValidatorInfo = mkValidatorInfo (stakeValidator stake) + , proposalPolicyInfo = mkPolicyInfo (proposalPolicy governorSTAssetClass) + , proposalValidatorInfo = mkValidatorInfo (proposalValidator proposal) + , treasuryValidatorInfo = mkValidatorInfo (treasuryValidator authorityTokenSymbol) + , authorityTokenPolicyInfo = mkPolicyInfo (authorityTokenPolicy authorityToken) + } + where + governor :: Governor + governor = + Governor + { Governor.gstOutRef = params.governorInitialSpend + , Governor.gtClassRef = params.gtClassRef + , Governor.maximumCosigners = params.maximumCosigners + } + + authorityToken :: AuthorityToken + authorityToken = authorityTokenFromGovernor governor + + authorityTokenSymbol :: CurrencySymbol + authorityTokenSymbol = authorityTokenSymbolFromGovernor governor + + governorSTAssetClass :: AssetClass + governorSTAssetClass = + Value.assetClass (mintingPolicySymbol $ mkMintingPolicy $ governorPolicy governor) "" + + proposal :: Proposal + proposal = proposalFromGovernor governor + + stake :: Stake + stake = stakeFromGovernor governor + +{- | Params required for creating script export. + + @since 0.2.0 +-} +data ScriptParams where + ScriptParams :: + { governorInitialSpend :: TxOutRef + , gtClassRef :: Tagged GTTag AssetClass + , maximumCosigners :: Integer + } -> + ScriptParams + deriving anyclass (Aeson.ToJSON, Aeson.FromJSON) + deriving stock (Show, Eq, GHC.Generic, Ord) + +{- | Scripts that get exported. + + @since 0.2.0 +-} +data AgoraScripts = AgoraScripts + { governorPolicyInfo :: PolicyInfo + , governorValidatorInfo :: ValidatorInfo + , stakePolicyInfo :: PolicyInfo + , stakeValidatorInfo :: ValidatorInfo + , proposalPolicyInfo :: PolicyInfo + , proposalValidatorInfo :: ValidatorInfo + , treasuryValidatorInfo :: ValidatorInfo + , authorityTokenPolicyInfo :: PolicyInfo + } + deriving anyclass + ( -- | @since 0.2.0 + Aeson.ToJSON + , -- | @since 0.2.0 + Aeson.FromJSON + ) + deriving stock + ( -- | @since 0.2.0 + Show + , -- | @since 0.2.0 + Eq + , -- | @since 0.2.0 + GHC.Generic + ) diff --git a/agora-scripts/ScriptExport/API.hs b/agora-scripts/ScriptExport/API.hs new file mode 100644 index 0000000..e074dab --- /dev/null +++ b/agora-scripts/ScriptExport/API.hs @@ -0,0 +1,100 @@ +{- | Module : ScriptExport.API + Maintainer : emi@haskell.fyi + Description: API for script exporter. + + API for script exporter. +-} +module ScriptExport.API ( + API, + runServer, +) where + +import Codec.Serialise.Orphans () +import Data.Aeson qualified as Aeson +import Data.Cache.Cached (cachedFor) +import Data.Function ((&)) +import Data.Proxy (Proxy (Proxy)) +import Data.Text (Text) +import GHC.Generics qualified as GHC +import Network.HTTP.Types qualified as Http +import Network.Wai qualified as Wai +import Network.Wai.Handler.Warp qualified as Warp +import Network.Wai.Middleware.Cors (CorsResourcePolicy (corsRequestHeaders), cors, simpleCorsResourcePolicy) +import Prettyprinter (Pretty (pretty), defaultLayoutOptions, hsep, layoutPretty, viaShow) +import Prettyprinter.Render.String (renderString) +import ScriptExport.Options (Options (..)) +import ScriptExport.Types (Builders, ScriptQuery, runQuery) +import ScriptExport.Types qualified as Builders +import Servant.API (Get, JSON, Post, ReqBody, (:<|>) (..), type (:>)) +import Servant.Server qualified as Servant +import System.Clock (TimeSpec (TimeSpec)) +import Text.Printf (printf) + +{- | Servant API type for script generation. + + @since 0.2.0 +-} +type API = + "query-script" :> ReqBody '[JSON] ScriptQuery :> Post '[JSON] Aeson.Value + :<|> "info" :> Get '[JSON] ServerInfo + +{- | Information about the server. + + @since 0.2.0 +-} +data ServerInfo = ServerInfo + { revision :: Text + , exposedBuilders :: [Text] + } + deriving anyclass + ( -- | @since 0.2.0 + Aeson.ToJSON + , -- | @since 0.2.0 + Aeson.FromJSON + ) + deriving stock + ( -- | @since 0.2.0 + Show + , -- | @since 0.2.0 + Eq + , -- | @since 0.2.0 + GHC.Generic + ) + +-- | Run a Warp server that exposes a script generation endpoint. +runServer :: Text -> Builders -> Options -> IO () +runServer revision builders options = do + let settings = + Warp.defaultSettings + & Warp.setPort options.port + & Warp.setLogger + ( \req status _maybeFileSize -> + putStrLn . renderString . layoutPretty defaultLayoutOptions $ + hsep + [ "[info]" + , viaShow $ Wai.requestMethod req + , viaShow $ Wai.rawPathInfo req + , "(" <> pretty (Http.statusCode status) <> ")" + ] + ) + + corsPolicy = + simpleCorsResourcePolicy + { -- NOTE: Webpack dev server requires this for CORS workaround. + corsRequestHeaders = "content-type" : corsRequestHeaders simpleCorsResourcePolicy + } + corsMiddleware = cors . const $ Just corsPolicy + + -- Scripts stay cached for five minutes + query <- cachedFor (Just $ TimeSpec 300 0) (`runQuery` builders) + + let serverInfo = + ServerInfo + { revision = revision + , exposedBuilders = Builders.toList builders + } + + printf "[info] Running 'agora-scripts' on :%d\n" (Warp.getPort settings) + Servant.serve (Proxy @API) (query :<|> pure serverInfo) + & corsMiddleware + & Warp.runSettings settings diff --git a/agora-scripts/Options.hs b/agora-scripts/ScriptExport/Options.hs similarity index 89% rename from agora-scripts/Options.hs rename to agora-scripts/ScriptExport/Options.hs index b0fa855..b37da56 100644 --- a/agora-scripts/Options.hs +++ b/agora-scripts/ScriptExport/Options.hs @@ -1,11 +1,11 @@ {- | -Module : Options +Module : ScriptExport.Options Maintainer : emi@haskell.fyi Description: Command line options for 'agora-scripts'. Command line options for 'agora-scripts'. -} -module Options (Options (..), parseOptions) where +module ScriptExport.Options (Options (..), parseOptions) where import Network.Wai.Handler.Warp qualified as Warp import Options.Applicative ((<**>)) diff --git a/agora-scripts/ScriptExport/Types.hs b/agora-scripts/ScriptExport/Types.hs new file mode 100644 index 0000000..b7dfcac --- /dev/null +++ b/agora-scripts/ScriptExport/Types.hs @@ -0,0 +1,94 @@ +{- | +Module : ScriptExport.Types +Maintainer : emi@haskell.fyi +Description: Param and script types for generation. + +Param and script types for generation. +-} +module ScriptExport.Types ( + ScriptQuery (..), + Builders, + runQuery, + insertBuilder, + toList, +) where + +import Data.Aeson qualified as Aeson +import Data.Coerce (coerce) +import Data.Default.Class (Default (def)) +import Data.Hashable (Hashable) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import GHC.Generics qualified as GHC + +{- | Query data for getting script info. + + @since 0.2.0 +-} +data ScriptQuery = ScriptQuery + { name :: Text + , paramsPayload :: Aeson.Value + } + deriving anyclass + ( -- | @since 0.2.0 + Aeson.ToJSON + , -- | @since 0.2.0 + Aeson.FromJSON + ) + deriving stock + ( -- | @since 0.2.0 + Show + , -- | @since 0.2.0 + Eq + , -- | @since 0.2.0 + GHC.Generic + , -- | @since 0.2.0 + Ord + ) + deriving anyclass + ( -- | @since 0.2.0 + Hashable + ) + +{- | Run a query on Builders. + + @since 0.2.0 +-} +runQuery :: ScriptQuery -> Builders -> Aeson.Value +runQuery s = + maybe Aeson.Null ($ s.paramsPayload) . Map.lookup s.name . getBuilders + +{- | Represents a list of named pure functions. + + @since 0.2.0 +-} +newtype Builders = Builders + { getBuilders :: Map Text (Aeson.Value -> Aeson.Value) + } + +-- | @since 0.2.0 +instance Default Builders where + def = Builders Map.empty + +{- | Insert a pure function into the Builders map. + + @since 0.2.0 +-} +insertBuilder :: + forall p s. + (Aeson.FromJSON p, Aeson.ToJSON s) => + Text -> + (p -> s) -> + Builders -> + Builders +insertBuilder k = coerce . Map.insert k . throughJSON + where + throughJSON f = Aeson.toJSON . \case { Aeson.Error _ -> Nothing; Aeson.Success v -> Just (f v) } . Aeson.fromJSON + +{- | Get a list of the available builders. + + @since 0.2.0 +-} +toList :: Builders -> [Text] +toList = Map.keys . getBuilders diff --git a/agora-scripts/Scripts.hs b/agora-scripts/Scripts.hs deleted file mode 100644 index a665c96..0000000 --- a/agora-scripts/Scripts.hs +++ /dev/null @@ -1,14 +0,0 @@ -{- | Module : Scripts - Maintainer : emi@haskell.fyi - Description: Export scripts given configuration. - - Export scripts given configuration. --} -module Scripts (main) where - -import API (runServer) -import Options (parseOptions) - -main :: IO () -main = - parseOptions >>= runServer diff --git a/agora-scripts/Types.hs b/agora-scripts/Types.hs deleted file mode 100644 index 7a36404..0000000 --- a/agora-scripts/Types.hs +++ /dev/null @@ -1,84 +0,0 @@ -{- | -Module : Types -Maintainer : emi@haskell.fyi -Description: Param and script types for generation. - -Param and script types for generation. --} -module Types ( - ScriptParams (..), - AgoraScripts (..), - ScriptQuery (..), - Builders (..), - throughJSON, - runQuery, - insertBuilder, -) where - -import Agora.SafeMoney (GTTag) -import Agora.ScriptInfo (PolicyInfo, ValidatorInfo) -import Data.Aeson qualified as Aeson -import Data.Coerce (coerce) -import Data.Default.Class (Default (def)) -import Data.Hashable (Hashable) -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Tagged (Tagged) -import Data.Text (Text) -import GHC.Generics qualified as GHC -import PlutusLedgerApi.V1 (TxOutRef) -import PlutusLedgerApi.V1.Value (AssetClass) - --- | Params required for creating script export. -data ScriptParams where - ScriptParams :: - { governorInitialSpend :: TxOutRef - , gtClassRef :: Tagged GTTag AssetClass - , maximumCosigners :: Integer - } -> - ScriptParams - deriving anyclass (Aeson.ToJSON, Aeson.FromJSON) - deriving stock (Show, Eq, GHC.Generic, Ord) - --- | Scripts that get exported. -data AgoraScripts = AgoraScripts - { gitRev :: String - , governorPolicyInfo :: PolicyInfo - , governorValidatorInfo :: ValidatorInfo - , stakePolicyInfo :: PolicyInfo - , stakeValidatorInfo :: ValidatorInfo - , proposalPolicyInfo :: PolicyInfo - , proposalValidatorInfo :: ValidatorInfo - , treasuryValidatorInfo :: ValidatorInfo - , authorityTokenPolicyInfo :: PolicyInfo - } - deriving anyclass (Aeson.ToJSON, Aeson.FromJSON) - deriving stock (Show, Eq, GHC.Generic) - -data ScriptQuery = ScriptQuery - { name :: Text - , paramsPayload :: Aeson.Value - } - deriving anyclass (Aeson.ToJSON, Aeson.FromJSON) - deriving stock (Show, Eq, GHC.Generic, Ord) - deriving anyclass (Hashable) - --- | Run a query on Builders. -runQuery :: ScriptQuery -> Builders -> Aeson.Value -runQuery s (Builders b) = - maybe Aeson.Null ($ s.paramsPayload) (Map.lookup s.name b) - -throughJSON :: (Aeson.FromJSON p, Aeson.ToJSON s) => (p -> s) -> (Aeson.Value -> Aeson.Value) -throughJSON f = Aeson.toJSON . \case { Aeson.Error _ -> Nothing; Aeson.Success v -> Just (f v) } . Aeson.fromJSON - --- | Represents a list of named pure functions. -newtype Builders = Builders - { getBuilders :: Map Text (Aeson.Value -> Aeson.Value) - } - -instance Default Builders where - def = Builders Map.empty - --- | Insert a pure function into the Builders map. -insertBuilder :: (Aeson.FromJSON p, Aeson.ToJSON s) => Text -> (p -> s) -> Builders -> Builders -insertBuilder k = coerce . Map.insert k . throughJSON diff --git a/agora-scripts/agora-params.json b/agora-scripts/agora-params.json deleted file mode 100644 index abb0f3d..0000000 --- a/agora-scripts/agora-params.json +++ /dev/null @@ -1,11 +0,0 @@ -{ - "governorInitialSpend": { - "txOutRefId": "7be688c61c209dd7a9f4948090db0b031b11a8850b0ee4695f786fea85fbfdee", - "txOutRefIdx": 0 - }, - "gtClassRef": [ - "", - "" - ], - "maximumCosigners": 5 -} diff --git a/agora.cabal b/agora.cabal index 83d3189..b84abed 100644 --- a/agora.cabal +++ b/agora.cabal @@ -232,14 +232,14 @@ benchmark agora-bench executable agora-scripts import: lang, deps, exe-opts - main-is: Scripts.hs + main-is: Main.hs hs-source-dirs: agora-scripts other-modules: - API Codec.Serialise.Orphans Data.Cache.Cached - Options - Types + ScriptExport.API + ScriptExport.Options + ScriptExport.Types build-depends: , agora From 6a7e8369fdffe6d6d898d52de7c90510cd7823f0 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Mon, 27 Jun 2022 13:30:27 +0200 Subject: [PATCH 6/9] add better server error messages, cbor vs raw hex --- agora-scripts/Data/Cache/Cached.hs | 18 +++-- agora-scripts/Main.hs | 18 ++--- agora-scripts/ScriptExport/API.hs | 11 ++- agora-scripts/ScriptExport/Types.hs | 26 +++++- agora.cabal | 2 + agora/Agora/Aeson/Orphans.hs | 10 +++ agora/Agora/ScriptInfo.hs | 121 +++++++++++----------------- 7 files changed, 109 insertions(+), 97 deletions(-) diff --git a/agora-scripts/Data/Cache/Cached.hs b/agora-scripts/Data/Cache/Cached.hs index 0b1acb5..a0d5d89 100644 --- a/agora-scripts/Data/Cache/Cached.hs +++ b/agora-scripts/Data/Cache/Cached.hs @@ -6,7 +6,8 @@ -} module Data.Cache.Cached ( cached, - cachedFor, + cachedM, + cachedForM, ) where import Control.Monad.IO.Class (MonadIO (liftIO)) @@ -20,7 +21,14 @@ import System.Clock (TimeSpec) Uses a HashMap under the hood. -} cached :: (Monad m, MonadIO m, Hashable k, Ord k) => (k -> v) -> IO (k -> m v) -cached = cachedFor Nothing +cached f = cachedForM Nothing (pure . f) + +{- | 'cachedFor' but items last forever. + + Uses a HashMap under the hood. +-} +cachedM :: (Monad m, MonadIO m, Hashable k, Ord k) => (k -> m v) -> IO (k -> m v) +cachedM = cachedForM Nothing {- | Create a cached version of a function tainting result with MonadIO context. @@ -28,13 +36,13 @@ cached = cachedFor Nothing Uses a HashMap under the hood. -} -cachedFor :: (Monad m, MonadIO m, Hashable k, Ord k) => Maybe TimeSpec -> (k -> v) -> IO (k -> m v) -cachedFor t f = +cachedForM :: (Monad m, MonadIO m, Hashable k, Ord k) => Maybe TimeSpec -> (k -> m v) -> IO (k -> m v) +cachedForM t f = Cache.newCache t <&> \cache k -> do res <- liftIO $ Cache.lookup cache k case res of Nothing -> do - let v = f k + v <- f k liftIO $ Cache.insert cache k v pure v Just v -> do diff --git a/agora-scripts/Main.hs b/agora-scripts/Main.hs index 3bb85a1..7d25b43 100644 --- a/agora-scripts/Main.hs +++ b/agora-scripts/Main.hs @@ -15,7 +15,7 @@ import Agora.Governor.Scripts (authorityTokenFromGovernor, authorityTokenSymbolF import Agora.Proposal (Proposal) import Agora.Proposal.Scripts (proposalPolicy, proposalValidator) import Agora.SafeMoney (GTTag) -import Agora.ScriptInfo (PolicyInfo, ValidatorInfo, mkPolicyInfo, mkValidatorInfo) +import Agora.ScriptInfo (ScriptInfo, mkPolicyInfo, mkValidatorInfo) import Agora.Stake (Stake) import Agora.Stake.Scripts (stakePolicy, stakeValidator) import Agora.Treasury (treasuryValidator) @@ -119,14 +119,14 @@ data ScriptParams where @since 0.2.0 -} data AgoraScripts = AgoraScripts - { governorPolicyInfo :: PolicyInfo - , governorValidatorInfo :: ValidatorInfo - , stakePolicyInfo :: PolicyInfo - , stakeValidatorInfo :: ValidatorInfo - , proposalPolicyInfo :: PolicyInfo - , proposalValidatorInfo :: ValidatorInfo - , treasuryValidatorInfo :: ValidatorInfo - , authorityTokenPolicyInfo :: PolicyInfo + { governorPolicyInfo :: ScriptInfo + , governorValidatorInfo :: ScriptInfo + , stakePolicyInfo :: ScriptInfo + , stakeValidatorInfo :: ScriptInfo + , proposalPolicyInfo :: ScriptInfo + , proposalValidatorInfo :: ScriptInfo + , treasuryValidatorInfo :: ScriptInfo + , authorityTokenPolicyInfo :: ScriptInfo } deriving anyclass ( -- | @since 0.2.0 diff --git a/agora-scripts/ScriptExport/API.hs b/agora-scripts/ScriptExport/API.hs index e074dab..c41b48a 100644 --- a/agora-scripts/ScriptExport/API.hs +++ b/agora-scripts/ScriptExport/API.hs @@ -11,7 +11,7 @@ module ScriptExport.API ( import Codec.Serialise.Orphans () import Data.Aeson qualified as Aeson -import Data.Cache.Cached (cachedFor) +import Data.Cache.Cached (cachedForM) import Data.Function ((&)) import Data.Proxy (Proxy (Proxy)) import Data.Text (Text) @@ -35,8 +35,11 @@ import Text.Printf (printf) @since 0.2.0 -} type API = - "query-script" :> ReqBody '[JSON] ScriptQuery :> Post '[JSON] Aeson.Value - :<|> "info" :> Get '[JSON] ServerInfo + "query-script" + :> ReqBody '[JSON] ScriptQuery + :> Post '[JSON] Aeson.Value + :<|> "info" + :> Get '[JSON] ServerInfo {- | Information about the server. @@ -86,7 +89,7 @@ runServer revision builders options = do corsMiddleware = cors . const $ Just corsPolicy -- Scripts stay cached for five minutes - query <- cachedFor (Just $ TimeSpec 300 0) (`runQuery` builders) + query <- cachedForM (Just $ TimeSpec 300 0) (`runQuery` builders) let serverInfo = ServerInfo diff --git a/agora-scripts/ScriptExport/Types.hs b/agora-scripts/ScriptExport/Types.hs index b7dfcac..c91805e 100644 --- a/agora-scripts/ScriptExport/Types.hs +++ b/agora-scripts/ScriptExport/Types.hs @@ -14,6 +14,7 @@ module ScriptExport.Types ( ) where import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy.Char8 qualified as LBS import Data.Coerce (coerce) import Data.Default.Class (Default (def)) import Data.Hashable (Hashable) @@ -21,6 +22,7 @@ import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Text (Text) import GHC.Generics qualified as GHC +import Servant qualified {- | Query data for getting script info. @@ -55,16 +57,20 @@ data ScriptQuery = ScriptQuery @since 0.2.0 -} -runQuery :: ScriptQuery -> Builders -> Aeson.Value +runQuery :: ScriptQuery -> Builders -> Servant.Handler Aeson.Value runQuery s = - maybe Aeson.Null ($ s.paramsPayload) . Map.lookup s.name . getBuilders + maybe + (Servant.throwError Servant.err404 {Servant.errBody = "Builder not found"}) + ($ s.paramsPayload) + . Map.lookup s.name + . getBuilders {- | Represents a list of named pure functions. @since 0.2.0 -} newtype Builders = Builders - { getBuilders :: Map Text (Aeson.Value -> Aeson.Value) + { getBuilders :: Map Text (Aeson.Value -> Servant.Handler Aeson.Value) } -- | @since 0.2.0 @@ -84,7 +90,19 @@ insertBuilder :: Builders insertBuilder k = coerce . Map.insert k . throughJSON where - throughJSON f = Aeson.toJSON . \case { Aeson.Error _ -> Nothing; Aeson.Success v -> Just (f v) } . Aeson.fromJSON + throughJSON :: + forall p s. + (Aeson.FromJSON p, Aeson.ToJSON s) => + (p -> s) -> + (Aeson.Value -> Servant.Handler Aeson.Value) + throughJSON f v = + case Aeson.fromJSON v of + Aeson.Error e -> + Servant.throwError $ + Servant.err400 + { Servant.errBody = LBS.pack e + } + Aeson.Success v' -> pure . Aeson.toJSON $ f v' {- | Get a list of the available builders. diff --git a/agora.cabal b/agora.cabal index b84abed..143f770 100644 --- a/agora.cabal +++ b/agora.cabal @@ -91,7 +91,9 @@ common deps , ansi-terminal , base >=4.14 && <5 , base-compat + , base16 , bytestring + , cardano-binary , cardano-prelude , containers , data-default diff --git a/agora/Agora/Aeson/Orphans.hs b/agora/Agora/Aeson/Orphans.hs index 6c14c62..2408add 100644 --- a/agora/Agora/Aeson/Orphans.hs +++ b/agora/Agora/Aeson/Orphans.hs @@ -20,6 +20,7 @@ import Data.Text.Encoding qualified as T import PlutusLedgerApi.V1 qualified as Plutus import PlutusLedgerApi.V1.Bytes qualified as Plutus +import PlutusLedgerApi.V1.Scripts qualified as Plutus import PlutusLedgerApi.V1.Value qualified as Plutus -------------------------------------------------------------------------------- @@ -109,6 +110,15 @@ deriving via instance (Aeson.FromJSON Plutus.ValidatorHash) +deriving via + (AsBase16Bytes Plutus.ScriptHash) + instance + (Aeson.ToJSON Plutus.ScriptHash) +deriving via + (AsBase16Bytes Plutus.ScriptHash) + instance + (Aeson.FromJSON Plutus.ScriptHash) + deriving via (AsBase16Bytes Plutus.BuiltinByteString) instance diff --git a/agora/Agora/ScriptInfo.hs b/agora/Agora/ScriptInfo.hs index 698c9c5..d4beba1 100644 --- a/agora/Agora/ScriptInfo.hs +++ b/agora/Agora/ScriptInfo.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + {- | Module : Agora.ScriptInfo Maintainer : emi@haskell.fyi @@ -7,8 +9,6 @@ Exportable script bundles for off-chain consumption. -} module Agora.ScriptInfo ( -- * Types - PolicyInfo (..), - ValidatorInfo (..), ScriptInfo (..), -- * Introduction functions @@ -17,100 +17,71 @@ module Agora.ScriptInfo ( ) where import Agora.Aeson.Orphans () +import Cardano.Binary qualified as CBOR +import Codec.Serialise qualified as Codec import Data.Aeson qualified as Aeson +import Data.ByteString.Base16 qualified as Base16 +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Short qualified as SBS +import Data.Text (Text) import GHC.Generics qualified as GHC -import Plutarch.Api.V1 (PMintingPolicy, PValidator, mintingPolicySymbol, mkMintingPolicy, mkValidator, validatorHash) +import Plutarch.Api.V1 (PMintingPolicy, PValidator, mkMintingPolicy, mkValidator, scriptHash) import PlutusLedgerApi.V1 ( - BuiltinByteString, - CurrencySymbol, - MintingPolicy, + MintingPolicy (getMintingPolicy), Script, - Validator, - ValidatorHash, + Validator (getValidator), ) - --- | Bundle containing a 'Script' and its hash. -data ScriptInfo = ScriptInfo - { script :: Script - -- ^ The validator script. - , hash :: BuiltinByteString - -- ^ Hash of the script. - } - deriving stock (Show, Eq, GHC.Generic) - deriving anyclass (Aeson.ToJSON, Aeson.FromJSON) +import PlutusLedgerApi.V1.Scripts (ScriptHash) {- | Bundle containing a 'Validator' and its hash. - @since 0.1.0 + @since 0.2.0 -} -data ValidatorInfo = ValidatorInfo - { script :: Validator - -- ^ The validator script. - , hash :: ValidatorHash +data ScriptInfo = ScriptInfo + { cborHex :: Text + -- ^ The validator script encoded as cbor hex. + , rawHex :: Text + -- ^ The validator script encoded as raw hex. + , hash :: ScriptHash -- ^ Hash of the validator. } deriving stock - ( -- | @since 0.1.0 + ( -- | @since 0.2.0 Show - , -- | @since 0.1.0 + , -- | @since 0.2.0 Eq - , -- | @since 0.1.0 + , -- | @since 0.2.0 GHC.Generic ) deriving anyclass - ( -- | @since 0.1.0 + ( -- | @since 0.2.0 Aeson.ToJSON - , -- | @since 0.1.0 + , -- | @since 0.2.0 Aeson.FromJSON ) -{- | Create a 'ValidatorInfo' given a Plutarch term. +mkScriptInfo :: Script -> ScriptInfo +mkScriptInfo script = + let scriptRaw = LBS.toStrict $ Codec.serialise script + scriptCBOR = CBOR.serialize' $ SBS.toShort scriptRaw + in ScriptInfo + { cborHex = Base16.encodeBase16 scriptCBOR + , rawHex = Base16.encodeBase16 scriptRaw + , hash = scriptHash script + } - @since 0.1.0 +{- | Create a 'ScriptInfo' given a Plutarch term of a policy. + + @since 0.2.0 -} -mkValidatorInfo :: ClosedTerm PValidator -> ValidatorInfo -mkValidatorInfo term = - ValidatorInfo - { script = validator - , hash = validatorHash validator - } - where - validator = mkValidator term - -{- | Bundle containing a 'MintingPolicy' and its symbol. - - @since 0.1.0 --} -data PolicyInfo = PolicyInfo - { policy :: MintingPolicy - -- ^ The minting policy. - , currencySymbol :: CurrencySymbol - -- ^ The symbol given by the minting policy. - } - deriving stock - ( -- | @since 0.1.0 - Show - , -- | @since 0.1.0 - Eq - , -- | @since 0.1.0 - GHC.Generic - ) - deriving anyclass - ( -- | @since 0.1.0 - Aeson.ToJSON - , -- | @since 0.1.0 - Aeson.FromJSON - ) - -{- | Create a 'PolicyInfo' given a Plutarch term. - - @since 0.1.0 --} -mkPolicyInfo :: ClosedTerm PMintingPolicy -> PolicyInfo +mkPolicyInfo :: ClosedTerm PMintingPolicy -> ScriptInfo mkPolicyInfo term = - PolicyInfo - { policy = policy - , currencySymbol = mintingPolicySymbol policy - } - where - policy = mkMintingPolicy term + mkScriptInfo (getMintingPolicy $ mkMintingPolicy term) + +{- | Create a 'ScriptInfo' given a Plutarch term of a validator. + + @since 0.2.0 +-} +mkValidatorInfo :: ClosedTerm PValidator -> ScriptInfo +mkValidatorInfo term = + mkScriptInfo (getValidator $ mkValidator term) From 8ce030cf24edf775b8249f8129207139e0bae08b Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Tue, 28 Jun 2022 21:08:13 +0200 Subject: [PATCH 7/9] use `Capture` to make API more neat, update bench --- agora-scripts/Main.hs | 12 ++++---- agora-scripts/ScriptExport/API.hs | 47 ++++++++++++++++++------------- 2 files changed, 33 insertions(+), 26 deletions(-) diff --git a/agora-scripts/Main.hs b/agora-scripts/Main.hs index 7d25b43..3a9d94d 100644 --- a/agora-scripts/Main.hs +++ b/agora-scripts/Main.hs @@ -52,12 +52,12 @@ builders = def & insertBuilder "governorPolicy" ((.governorPolicyInfo) . agoraScripts) & insertBuilder "governorValidator" ((.governorValidatorInfo) . agoraScripts) - & insertBuilder "stakePolicyInfo" ((.stakePolicyInfo) . agoraScripts) - & insertBuilder "stakeValidatorInfo" ((.stakeValidatorInfo) . agoraScripts) - & insertBuilder "proposalPolicyInfo" ((.proposalPolicyInfo) . agoraScripts) - & insertBuilder "proposalValidatorInfo" ((.proposalValidatorInfo) . agoraScripts) - & insertBuilder "treasuryValidatorInfo" ((.treasuryValidatorInfo) . agoraScripts) - & insertBuilder "authorityTokenPolicyInfo" ((.authorityTokenPolicyInfo) . agoraScripts) + & insertBuilder "stakePolicy" ((.stakePolicyInfo) . agoraScripts) + & insertBuilder "stakeValidator" ((.stakeValidatorInfo) . agoraScripts) + & insertBuilder "proposalPolicy" ((.proposalPolicyInfo) . agoraScripts) + & insertBuilder "proposalValidator" ((.proposalValidatorInfo) . agoraScripts) + & insertBuilder "treasuryValidator" ((.treasuryValidatorInfo) . agoraScripts) + & insertBuilder "authorityTokenPolicy" ((.authorityTokenPolicyInfo) . agoraScripts) {- | Create scripts from params. diff --git a/agora-scripts/ScriptExport/API.hs b/agora-scripts/ScriptExport/API.hs index c41b48a..4fb70f1 100644 --- a/agora-scripts/ScriptExport/API.hs +++ b/agora-scripts/ScriptExport/API.hs @@ -23,9 +23,9 @@ import Network.Wai.Middleware.Cors (CorsResourcePolicy (corsRequestHeaders), cor import Prettyprinter (Pretty (pretty), defaultLayoutOptions, hsep, layoutPretty, viaShow) import Prettyprinter.Render.String (renderString) import ScriptExport.Options (Options (..)) -import ScriptExport.Types (Builders, ScriptQuery, runQuery) +import ScriptExport.Types (Builders, ScriptQuery (ScriptQuery), runQuery) import ScriptExport.Types qualified as Builders -import Servant.API (Get, JSON, Post, ReqBody, (:<|>) (..), type (:>)) +import Servant.API (Capture, Get, JSON, Post, ReqBody, (:<|>) (..), type (:>)) import Servant.Server qualified as Servant import System.Clock (TimeSpec (TimeSpec)) import Text.Printf (printf) @@ -35,11 +35,14 @@ import Text.Printf (printf) @since 0.2.0 -} type API = + -- /query-script/:name "query-script" - :> ReqBody '[JSON] ScriptQuery + :> Capture "name" Text + :> ReqBody '[JSON] Aeson.Value :> Post '[JSON] Aeson.Value + -- /info :<|> "info" - :> Get '[JSON] ServerInfo + :> Get '[JSON] ServerInfo {- | Information about the server. @@ -67,37 +70,41 @@ data ServerInfo = ServerInfo -- | Run a Warp server that exposes a script generation endpoint. runServer :: Text -> Builders -> Options -> IO () runServer revision builders options = do - let settings = + let logger req status _maybeFileSize = + putStrLn . renderString . layoutPretty defaultLayoutOptions $ + hsep + [ "[info]" + , viaShow $ Wai.requestMethod req + , viaShow $ Wai.rawPathInfo req + , "(" <> pretty (Http.statusCode status) <> ")" + ] + + settings = Warp.defaultSettings & Warp.setPort options.port - & Warp.setLogger - ( \req status _maybeFileSize -> - putStrLn . renderString . layoutPretty defaultLayoutOptions $ - hsep - [ "[info]" - , viaShow $ Wai.requestMethod req - , viaShow $ Wai.rawPathInfo req - , "(" <> pretty (Http.statusCode status) <> ")" - ] - ) + & Warp.setLogger logger corsPolicy = simpleCorsResourcePolicy { -- NOTE: Webpack dev server requires this for CORS workaround. corsRequestHeaders = "content-type" : corsRequestHeaders simpleCorsResourcePolicy } + corsMiddleware = cors . const $ Just corsPolicy - -- Scripts stay cached for five minutes - query <- cachedForM (Just $ TimeSpec 300 0) (`runQuery` builders) - - let serverInfo = + serverInfo = ServerInfo { revision = revision , exposedBuilders = Builders.toList builders } + -- Scripts stay cached for five minutes + query <- cachedForM (Just $ TimeSpec 300 0) (`runQuery` builders) + + let handler = (\name -> query . ScriptQuery name) :<|> pure serverInfo + printf "[info] Running 'agora-scripts' on :%d\n" (Warp.getPort settings) - Servant.serve (Proxy @API) (query :<|> pure serverInfo) + + Servant.serve (Proxy @API) handler & corsMiddleware & Warp.runSettings settings From be1fd594b6e0c24a91b8b93c09dbaee23d2d6796 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Wed, 29 Jun 2022 10:35:34 +0200 Subject: [PATCH 8/9] update command line options --- agora-scripts/ScriptExport/API.hs | 6 +++--- agora-scripts/ScriptExport/Options.hs | 16 ++++++++++++++-- 2 files changed, 17 insertions(+), 5 deletions(-) diff --git a/agora-scripts/ScriptExport/API.hs b/agora-scripts/ScriptExport/API.hs index 4fb70f1..f09ffd2 100644 --- a/agora-scripts/ScriptExport/API.hs +++ b/agora-scripts/ScriptExport/API.hs @@ -35,12 +35,12 @@ import Text.Printf (printf) @since 0.2.0 -} type API = - -- /query-script/:name + -- POST /query-script/:name "query-script" :> Capture "name" Text :> ReqBody '[JSON] Aeson.Value :> Post '[JSON] Aeson.Value - -- /info + -- GET /info :<|> "info" :> Get '[JSON] ServerInfo @@ -106,5 +106,5 @@ runServer revision builders options = do printf "[info] Running 'agora-scripts' on :%d\n" (Warp.getPort settings) Servant.serve (Proxy @API) handler - & corsMiddleware + & (if options.enableCorsMiddleware then corsMiddleware else id) & Warp.runSettings settings diff --git a/agora-scripts/ScriptExport/Options.hs b/agora-scripts/ScriptExport/Options.hs index b37da56..2ea6a57 100644 --- a/agora-scripts/ScriptExport/Options.hs +++ b/agora-scripts/ScriptExport/Options.hs @@ -11,8 +11,9 @@ import Network.Wai.Handler.Warp qualified as Warp import Options.Applicative ((<**>)) import Options.Applicative qualified as Opt -newtype Options = Options +data Options = Options { port :: Warp.Port + , enableCorsMiddleware :: Bool } deriving stock (Show, Eq) @@ -25,7 +26,18 @@ opt = <> Opt.short 'p' <> Opt.metavar "PORT" <> Opt.value 3939 - <> Opt.help "The path where the script configuration is." + <> Opt.help "The port to run the server on." + ) + <*> Opt.switch + ( Opt.long "enable-cors-middleware" + <> Opt.short 'c' + <> Opt.help + ( unwords + [ "Enable cors middleware." + , "This is usually required for some local servers." + , "For security reasons, this should be disabled in production." + ] + ) ) parseOptions :: IO Options From a2f849441f7931c09fec62c270f63be77a2d4847 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Wed, 29 Jun 2022 11:36:13 +0200 Subject: [PATCH 9/9] add `agora-scripts` explainer in README.md --- README.md | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/README.md b/README.md index c21076b..9a3eb30 100644 --- a/README.md +++ b/README.md @@ -21,6 +21,18 @@ An up to date version of the [Nix package manager](nixos.org) (>=2.3) is require Open a development shell with `nix develop` and build the project with `cabal build`. Those pained by the need to remember to enter a Nix shell may consider using [nix-direnv](https://github.com/nix-community/nix-direnv). +## `agora-scripts` HTTP export server + +To use scripts in a frontend, you can use the `agora-scripts` executable which allows you to query them on-demand. + +The CTL repo [`agora-offchain`](https://github.com/mlabs-haskell/agora-offchain) already has the setup prepared for this feature. + +In order to run the server, simply run the following command: + +```sh +cabal run agora-scripts -- --enable-cors-middleware +``` + ## Documentation Documentation for Agora is hosted on Notion. You can find the specs [here](https://liqwid.notion.site/e85c09d2c9a542b19aac8dd3d6caa98b?v=d863219cd6a14082a661c4959cabd6e7).