use plutarch-script-export library
This commit is contained in:
Emily Martins
parent
1533da68ec
commit
835e04e049
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
|
||||
Loading…
Add table
Add a link
Reference in a new issue