Merge pull request #139 from Liqwid-Labs/emiflake/use-pse

Use `plutarch-script-export` library

agora-scripts/Codec/Serialise/Orphans.hs

@@ -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)

agora-scripts/Data/Cache/Cached.hs

@@ -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

agora-scripts/Main.hs

@@ -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 ()

agora-scripts/ScriptExport/API.hs

@@ -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

agora-scripts/ScriptExport/Options.hs

@@ -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."
-        )

agora-scripts/ScriptExport/Types.hs

@@ -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

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

agora/Agora/ScriptInfo.hs

@@ -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)

flake.nix

@@ -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: