Merge pull request #139 from Liqwid-Labs/emiflake/use-pse
Use `plutarch-script-export` library
This commit is contained in:
Emily
GitHub
commit
9fce93829b
10 changed files with 887 additions and 466 deletions
|
|
@ -1,34 +0,0 @@
|
|||
{-# 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)
|
||||
|
|
@ -1,49 +0,0 @@
|
|||
{- | 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
|
||||
|
|
@ -15,7 +15,6 @@ import Agora.Governor.Scripts (authorityTokenFromGovernor, authorityTokenSymbolF
|
|||
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)
|
||||
|
|
@ -32,6 +31,7 @@ import PlutusLedgerApi.V1.Value (AssetClass, CurrencySymbol)
|
|||
import PlutusLedgerApi.V1.Value qualified as Value
|
||||
import ScriptExport.API (runServer)
|
||||
import ScriptExport.Options (parseOptions)
|
||||
import ScriptExport.ScriptInfo (ScriptInfo, mkPolicyInfo, mkValidatorInfo)
|
||||
import ScriptExport.Types (Builders, insertBuilder)
|
||||
|
||||
main :: IO ()
|
||||
|
|
|
|||
|
|
@ -1,110 +0,0 @@
|
|||
{- | 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
|
||||
|
|
@ -1,51 +0,0 @@
|
|||
{- |
|
||||
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."
|
||||
)
|
||||
|
|
@ -1,112 +0,0 @@
|
|||
{- |
|
||||
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
|
||||
22
agora.cabal
22
agora.cabal
|
|
@ -89,7 +89,7 @@ common deps
|
|||
build-depends:
|
||||
, aeson
|
||||
, ansi-terminal
|
||||
, base >=4.14 && <5
|
||||
, base >=4.14 && <5
|
||||
, base-compat
|
||||
, base16
|
||||
, bytestring
|
||||
|
|
@ -103,6 +103,7 @@ common deps
|
|||
, plutarch
|
||||
, plutarch-numeric
|
||||
, plutarch-safe-money
|
||||
, plutarch-script-export
|
||||
, plutus-core
|
||||
, plutus-ledger-api
|
||||
, plutus-tx
|
||||
|
|
@ -154,7 +155,6 @@ library
|
|||
Agora.Proposal.Scripts
|
||||
Agora.Proposal.Time
|
||||
Agora.SafeMoney
|
||||
Agora.ScriptInfo
|
||||
Agora.Stake
|
||||
Agora.Stake.Scripts
|
||||
Agora.Treasury
|
||||
|
|
@ -237,27 +237,9 @@ executable agora-scripts
|
|||
main-is: Main.hs
|
||||
hs-source-dirs: agora-scripts
|
||||
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
|
||||
|
|
|
|||
|
|
@ -1,87 +0,0 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
{- |
|
||||
Module : Agora.ScriptInfo
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Exportable script bundles for off-chain consumption.
|
||||
|
||||
Exportable script bundles for off-chain consumption.
|
||||
-}
|
||||
module Agora.ScriptInfo (
|
||||
-- * Types
|
||||
ScriptInfo (..),
|
||||
|
||||
-- * Introduction functions
|
||||
mkValidatorInfo,
|
||||
mkPolicyInfo,
|
||||
) 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, 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.2.0
|
||||
-}
|
||||
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.2.0
|
||||
Show
|
||||
, -- | @since 0.2.0
|
||||
Eq
|
||||
, -- | @since 0.2.0
|
||||
GHC.Generic
|
||||
)
|
||||
deriving anyclass
|
||||
( -- | @since 0.2.0
|
||||
Aeson.ToJSON
|
||||
, -- | @since 0.2.0
|
||||
Aeson.FromJSON
|
||||
)
|
||||
|
||||
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
|
||||
}
|
||||
|
||||
{- | Create a 'ScriptInfo' given a Plutarch term of a policy.
|
||||
|
||||
@since 0.2.0
|
||||
-}
|
||||
mkPolicyInfo :: ClosedTerm PMintingPolicy -> ScriptInfo
|
||||
mkPolicyInfo 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)
|
||||
880
flake.lock
generated
880
flake.lock
generated
File diff suppressed because it is too large
Load diff
|
|
@ -23,6 +23,9 @@
|
|||
inputs.plutarch-safe-money.url =
|
||||
"github:Liqwid-Labs/plutarch-safe-money?rev=9f968b80189c7e4b335527cd5b103dc26952f667";
|
||||
|
||||
inputs.plutarch-script-export.url =
|
||||
"github:Liqwid-Labs/plutarch-script-export?ref=main";
|
||||
|
||||
# Testing
|
||||
inputs.plutarch-quickcheck.url =
|
||||
"github:liqwid-labs/plutarch-quickcheck?ref=staging";
|
||||
|
|
@ -136,6 +139,7 @@
|
|||
"${inputs.plutarch-safe-money}"
|
||||
"${inputs.plutarch-quickcheck}"
|
||||
"${inputs.plutarch-context-builder}"
|
||||
"${inputs.plutarch-script-export}"
|
||||
]
|
||||
);
|
||||
|
||||
|
|
@ -148,7 +152,7 @@
|
|||
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";
|
||||
cabalProjectLocal = (o'.cabalProjectLocal or "") + " , cache >= 0.1.3.0 ";
|
||||
};
|
||||
|
||||
projectForGhc = compiler-nix-name: system:
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue