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.
This commit is contained in:
Emily Martins
parent
7466901875
commit
a5765a355d
10 changed files with 345 additions and 267 deletions
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
144
agora-scripts/Main.hs
Normal file
144
agora-scripts/Main.hs
Normal file
|
|
@ -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
|
||||
)
|
||||
100
agora-scripts/ScriptExport/API.hs
Normal file
100
agora-scripts/ScriptExport/API.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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 ((<**>))
|
||||
94
agora-scripts/ScriptExport/Types.hs
Normal file
94
agora-scripts/ScriptExport/Types.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
{
|
||||
"governorInitialSpend": {
|
||||
"txOutRefId": "7be688c61c209dd7a9f4948090db0b031b11a8850b0ee4695f786fea85fbfdee",
|
||||
"txOutRefIdx": 0
|
||||
},
|
||||
"gtClassRef": [
|
||||
"",
|
||||
""
|
||||
],
|
||||
"maximumCosigners": 5
|
||||
}
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue