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). diff --git a/agora-scripts/Codec/Serialise/Orphans.hs b/agora-scripts/Codec/Serialise/Orphans.hs new file mode 100644 index 0000000..f310abd --- /dev/null +++ b/agora-scripts/Codec/Serialise/Orphans.hs @@ -0,0 +1,34 @@ +{-# 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) +import Data.Tagged (Tagged (Tagged)) +import PlutusLedgerApi.V1 (TxId, TxOutRef) +import PlutusLedgerApi.V1.Value (AssetClass, CurrencySymbol, TokenName) + +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) diff --git a/agora-scripts/Data/Cache/Cached.hs b/agora-scripts/Data/Cache/Cached.hs new file mode 100644 index 0000000..a0d5d89 --- /dev/null +++ b/agora-scripts/Data/Cache/Cached.hs @@ -0,0 +1,49 @@ +{- | Module : API + Maintainer : emi@haskell.fyi + Description: API for script exporter. + + API for script exporter. +-} +module Data.Cache.Cached ( + cached, + cachedM, + cachedForM, +) 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 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. + + Results are cached dependent on the first argument, @'Maybe' 'TimeSpec'@. + + Uses a HashMap under the hood. +-} +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 + v <- f k + liftIO $ Cache.insert cache k v + pure v + Just v -> do + pure v diff --git a/agora-scripts/Main.hs b/agora-scripts/Main.hs new file mode 100644 index 0000000..3a9d94d --- /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 (ScriptInfo, 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 "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. + + @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 :: ScriptInfo + , governorValidatorInfo :: ScriptInfo + , stakePolicyInfo :: ScriptInfo + , stakeValidatorInfo :: ScriptInfo + , proposalPolicyInfo :: ScriptInfo + , proposalValidatorInfo :: ScriptInfo + , treasuryValidatorInfo :: ScriptInfo + , authorityTokenPolicyInfo :: ScriptInfo + } + 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/Options.hs b/agora-scripts/Options.hs deleted file mode 100644 index e56d09a..0000000 --- a/agora-scripts/Options.hs +++ /dev/null @@ -1,45 +0,0 @@ -{- | -Module : Options -Maintainer : emi@haskell.fyi -Description: Command line options for 'agora-scripts'. - -Command line options for 'agora-scripts'. --} -module Options (Options (..), parseOptions) where - -import Options.Applicative ((<**>)) -import Options.Applicative qualified as Opt - -data Options = Options - { config :: FilePath - , output :: FilePath - } - 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.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 - where - p = - Opt.info - (opt <**> Opt.helper) - ( Opt.fullDesc - <> Opt.progDesc "Generate Agora scripts for off-chain use." - ) diff --git a/agora-scripts/ScriptExport/API.hs b/agora-scripts/ScriptExport/API.hs new file mode 100644 index 0000000..f09ffd2 --- /dev/null +++ b/agora-scripts/ScriptExport/API.hs @@ -0,0 +1,110 @@ +{- | 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 (cachedForM) +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 (ScriptQuery), runQuery) +import ScriptExport.Types qualified as Builders +import Servant.API (Capture, 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 = + -- POST /query-script/:name + "query-script" + :> Capture "name" Text + :> ReqBody '[JSON] Aeson.Value + :> Post '[JSON] Aeson.Value + -- GET /info + :<|> "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 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 logger + + corsPolicy = + simpleCorsResourcePolicy + { -- NOTE: Webpack dev server requires this for CORS workaround. + corsRequestHeaders = "content-type" : corsRequestHeaders simpleCorsResourcePolicy + } + + corsMiddleware = cors . const $ Just corsPolicy + + 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) handler + & (if options.enableCorsMiddleware then corsMiddleware else id) + & Warp.runSettings settings diff --git a/agora-scripts/ScriptExport/Options.hs b/agora-scripts/ScriptExport/Options.hs new file mode 100644 index 0000000..2ea6a57 --- /dev/null +++ b/agora-scripts/ScriptExport/Options.hs @@ -0,0 +1,51 @@ +{- | +Module : ScriptExport.Options +Maintainer : emi@haskell.fyi +Description: Command line options for 'agora-scripts'. + +Command line options for 'agora-scripts'. +-} +module ScriptExport.Options (Options (..), parseOptions) where + +import Network.Wai.Handler.Warp qualified as Warp +import Options.Applicative ((<**>)) +import Options.Applicative qualified as Opt + +data Options = Options + { port :: Warp.Port + , enableCorsMiddleware :: Bool + } + deriving stock (Show, Eq) + +opt :: Opt.Parser Options +opt = + Options + <$> Opt.option + Opt.auto + ( Opt.long "port" + <> Opt.short 'p' + <> Opt.metavar "PORT" + <> Opt.value 3939 + <> 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 +parseOptions = Opt.execParser p + where + p = + Opt.info + (opt <**> Opt.helper) + ( Opt.fullDesc + <> Opt.progDesc "Generate Agora scripts for off-chain use." + ) diff --git a/agora-scripts/ScriptExport/Types.hs b/agora-scripts/ScriptExport/Types.hs new file mode 100644 index 0000000..c91805e --- /dev/null +++ b/agora-scripts/ScriptExport/Types.hs @@ -0,0 +1,112 @@ +{- | +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.ByteString.Lazy.Char8 qualified as LBS +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 +import Servant qualified + +{- | 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 -> Servant.Handler Aeson.Value +runQuery s = + 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 -> Servant.Handler 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 :: + 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. + + @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 132f5ce..0000000 --- a/agora-scripts/Scripts.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -{- | -Module : Scripts -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 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) - -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 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 8e8ba53..143f770 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), @@ -39,6 +39,7 @@ common lang DerivingStrategies DerivingVia DoAndIfThenElse + DuplicateRecordFields EmptyCase EmptyDataDecls EmptyDataDeriving @@ -90,7 +91,9 @@ common deps , ansi-terminal , base >=4.14 && <5 , base-compat + , base16 , bytestring + , cardano-binary , cardano-prelude , containers , data-default @@ -137,6 +140,7 @@ common exe-opts library import: lang, deps exposed-modules: + Agora.Aeson.Orphans Agora.AuthorityToken Agora.Effect Agora.Effect.GovernorMutation @@ -145,6 +149,7 @@ library Agora.Governor Agora.Governor.Scripts Agora.MultiSig + Agora.Plutarch.Orphans Agora.Proposal Agora.Proposal.Scripts Agora.Proposal.Time @@ -156,9 +161,6 @@ library Agora.Utils other-modules: - Agora.Aeson.Orphans - Agora.Plutarch.Orphans - hs-source-dirs: agora library pprelude @@ -232,13 +234,30 @@ 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: Options + other-modules: + Codec.Serialise.Orphans + Data.Cache.Cached + ScriptExport.API + ScriptExport.Options + ScriptExport.Types + build-depends: , agora + , cache + , clock + , containers , gitrev + , hashable + , http-types , optparse-applicative + , prettyprinter + , servant + , servant-server + , wai + , wai-cors + , warp 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..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,24 @@ 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 + (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..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,7 @@ Exportable script bundles for off-chain consumption. -} module Agora.ScriptInfo ( -- * Types - PolicyInfo (..), - ValidatorInfo (..), + ScriptInfo (..), -- * Introduction functions mkValidatorInfo, @@ -16,84 +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 PlutusLedgerApi.V1 (MintingPolicy, Validator, ValidatorHash) -import PlutusLedgerApi.V1.Value (CurrencySymbol) +import Plutarch.Api.V1 (PMintingPolicy, PValidator, mkMintingPolicy, mkValidator, scriptHash) +import PlutusLedgerApi.V1 ( + MintingPolicy (getMintingPolicy), + Script, + Validator (getValidator), + ) +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) 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: