From e862de7e59cd07d626be48457565dcd21c760d98 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Tue, 21 Jun 2022 14:48:31 +0200 Subject: [PATCH] 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: