add granular script querying support

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 =

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

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

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

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 (BuiltinByteString, CurrencySymbol (unCurrencySymbol), MintingPolicy, Script, Validator, ValidatorHash, unMintingPolicyScript)
-import PlutusLedgerApi.V1.Value (CurrencySymbol)
+
+-- | 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.