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)