create initial POC script generating API

agora-scripts/API.hs

@@ -1,68 +1,49 @@
 {-# LANGUAGE TemplateHaskell #-}
-{- |
-Module     : API
-Maintainer : emi@haskell.fyi
-Description: API for script exporter.
 
-API for script exporter.
+{- | Module     : API
+   Maintainer : emi@haskell.fyi
+   Description: API for script exporter.
+
+   API for script exporter.
 -}
+module API (
+  AgoraScripts (..),
+  ScriptParams (..),
+  API,
+  agoraScripts,
+  runServer,
+) where
 
-module API (AgoraScripts(..), ScriptParams(..), API, agoraScripts, runServer) where
-
-import Servant.API (type (:>), ReqBody, JSON, Post)
-import PlutusLedgerApi.V1 (TxOutRef)
-import Data.Tagged (Tagged)
-import Agora.SafeMoney (GTTag)
-import PlutusLedgerApi.V1.Value (AssetClass, CurrencySymbol)
-import qualified Data.Aeson as Aeson
-import qualified GHC.Generics as GHC
-import Agora.ScriptInfo (PolicyInfo, ValidatorInfo, mkPolicyInfo, mkValidatorInfo)
-import Agora.Stake (Stake(..))
-import Agora.Proposal (Proposal(..))
-import Agora.AuthorityToken (AuthorityToken(..), authorityTokenPolicy)
-import Agora.Governor (Governor(..))
-import Development.GitRev (gitBranch, gitHash)
-import qualified Agora.Governor as Governor
-import qualified PlutusLedgerApi.V1.Value as Value
-import Plutarch.Api.V1 (mintingPolicySymbol, mkMintingPolicy)
-import Agora.Governor.Scripts (governorPolicy, authorityTokenSymbolFromGovernor, authorityTokenFromGovernor, proposalFromGovernor, stakeFromGovernor, governorValidator)
+import Agora.AuthorityToken (AuthorityToken (..), authorityTokenPolicy)
+import Agora.Governor (Governor (..))
+import Agora.Governor qualified as Governor
+import Agora.Governor.Scripts (authorityTokenFromGovernor, authorityTokenSymbolFromGovernor, governorPolicy, governorValidator, proposalFromGovernor, stakeFromGovernor)
+import Agora.Proposal (Proposal (..))
+import Agora.Proposal.Scripts (proposalPolicy, proposalValidator)
+import Agora.ScriptInfo (mkPolicyInfo, mkValidatorInfo)
+import Agora.Stake (Stake (..))
+import Agora.Stake.Scripts (stakePolicy, stakeValidator)
 import Agora.Treasury (treasuryValidator)
-import Agora.Proposal.Scripts (proposalValidator, proposalPolicy)
-import Agora.Stake.Scripts (stakeValidator, stakePolicy)
-import qualified Servant.Server as Servant
-import Data.Proxy (Proxy(Proxy))
-import qualified Network.Wai.Handler.Warp as Warp
+import Codec.Serialise.Orphans ()
+import Data.Cache.Cached (cachedFor)
 import Data.Function ((&))
-import qualified Network.Wai as Wai
-import qualified Network.HTTP.Types as Http
-import Prettyprinter (layoutPretty, defaultLayoutOptions, hsep, viaShow, (<+>))
+import Data.Proxy (Proxy (Proxy))
+import Development.GitRev (gitBranch, gitHash)
+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 Options (Options (..))
+import Plutarch.Api.V1 (mintingPolicySymbol, mkMintingPolicy)
+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 Options (Options(..))
+import Servant.API (JSON, Post, ReqBody, type (:>))
+import Servant.Server qualified as Servant
+import System.Clock (TimeSpec (TimeSpec))
 import Text.Printf (printf)
-
--- | Params required for creating script export.
-data ScriptParams = ScriptParams
-  { governorInitialSpend :: TxOutRef
-  , gtClassRef :: Tagged GTTag AssetClass
-  , maximumCosigners :: Integer
-  }
-  deriving anyclass (Aeson.ToJSON, Aeson.FromJSON)
-  deriving stock (Show, Eq, GHC.Generic)
-
--- | Scripts that get exported.
-data AgoraScripts = AgoraScripts
-  { gitRev :: String
-  , governorPolicyInfo :: PolicyInfo
-  , governorValidatorInfo :: ValidatorInfo
-  , stakePolicyInfo :: PolicyInfo
-  , stakeValidatorInfo :: ValidatorInfo
-  , proposalPolicyInfo :: PolicyInfo
-  , proposalValidatorInfo :: ValidatorInfo
-  , treasuryValidatorInfo :: ValidatorInfo
-  , authorityTokenPolicyInfo :: PolicyInfo
-  }
-  deriving anyclass (Aeson.ToJSON, Aeson.FromJSON)
-  deriving stock (Show, Eq, GHC.Generic)
+import Types (AgoraScripts (..), ScriptParams (..))
 
 -- | Servant API type for script generation.
 type API = "generate-scripts" :> ReqBody '[JSON] ScriptParams :> Post '[JSON] AgoraScripts
@@ -84,8 +65,20 @@ runServer options = do
                     ]
             )
 
+      corsPolicy =
+        simpleCorsResourcePolicy
+          { -- NOTE: Webpack dev server requires this for CORS workaround.
+            corsRequestHeaders = "content-type" : corsRequestHeaders simpleCorsResourcePolicy
+          }
+      corsMiddleware = cors . const $ Just corsPolicy
+
+  -- Scripts stay cached for five minutes
+  agoraScripts' <- cachedFor (Just $ TimeSpec 300 0) agoraScripts
+
   printf "[info] Running 'agora-scripts' on :%d\n" (Warp.getPort settings)
-  Warp.runSettings settings $ Servant.serve (Proxy @API) (pure . agoraScripts)
+  Servant.serve (Proxy @API) agoraScripts'
+    & corsMiddleware
+    & Warp.runSettings settings
 
 -- | Create scripts from params.
 agoraScripts :: ScriptParams -> AgoraScripts
@@ -102,6 +95,8 @@ agoraScripts params =
     , authorityTokenPolicyInfo = mkPolicyInfo (authorityTokenPolicy authorityToken)
     }
   where
+    -- This encodes the git revision of the server. It's useful for the caller
+    -- to be able to ensure they are compatible with it.
     revision :: String
     revision = $(gitBranch) <> "@" <> $(gitHash)
 

agora-scripts/Cache.hs

@@ -0,0 +1 @@
+module Cache where

agora-scripts/Codec/Serialise/Orphans.hs

@@ -0,0 +1,41 @@
+{-# 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, serialise)
+import Data.Hashable (Hashable (hashWithSalt))
+import Data.Tagged (Tagged (Tagged))
+import PlutusLedgerApi.V1 (TxId, TxOutRef)
+import PlutusLedgerApi.V1.Value (AssetClass, CurrencySymbol, TokenName)
+import Types (ScriptParams)
+
+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)
+
+deriving anyclass instance Serialise ScriptParams
+
+instance Hashable ScriptParams where
+  hashWithSalt s scriptParams = hashWithSalt s (serialise scriptParams)

agora-scripts/Data/Cache/Cached.hs

@@ -0,0 +1,41 @@
+{- | Module     : API
+   Maintainer : emi@haskell.fyi
+   Description: API for script exporter.
+
+   API for script exporter.
+-}
+module Data.Cache.Cached (
+  cached,
+  cachedFor,
+) 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 = cachedFor 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.
+-}
+cachedFor :: (Monad m, MonadIO m, Hashable k, Ord k) => Maybe TimeSpec -> (k -> v) -> IO (k -> m v)
+cachedFor t f =
+  Cache.newCache t <&> \cache k -> do
+    res <- liftIO $ Cache.lookup cache k
+    case res of
+      Nothing -> do
+        let v = f k
+        liftIO $ Cache.insert cache k v
+        pure v
+      Just v -> do
+        pure v

agora-scripts/Options.hs

@@ -7,9 +7,9 @@ Command line options for 'agora-scripts'.
 -}
 module Options (Options (..), parseOptions) where
 
+import Network.Wai.Handler.Warp qualified as Warp
 import Options.Applicative ((<**>))
 import Options.Applicative qualified as Opt
-import qualified Network.Wai.Handler.Warp as Warp
 
 data Options = Options
   { port :: Warp.Port
@@ -19,7 +19,8 @@ data Options = Options
 opt :: Opt.Parser Options
 opt =
   Options
-    <$> Opt.option Opt.auto
+    <$> Opt.option
+      Opt.auto
       ( Opt.long "port"
           <> Opt.short 'p'
           <> Opt.metavar "PORT"

agora-scripts/Scripts.hs

@@ -1,19 +1,14 @@
-{-# LANGUAGE TemplateHaskell #-}
+{- | Module     : Scripts
+     Maintainer : emi@haskell.fyi
+     Description: Export scripts given configuration.
 
-{- |
-Module     : Scripts
-Maintainer : emi@haskell.fyi
-Description: Export scripts given configuration.
-
-Export scripts given configuration.
+     Export scripts given configuration.
 -}
-module Main (main) where
+module Scripts (main) where
 
-import Options (parseOptions)
 import API (runServer)
+import Options (parseOptions)
 
 main :: IO ()
-main = do
-  options <- parseOptions
-
-  runServer options
+main =
+  parseOptions >>= runServer

agora-scripts/Types.hs

@@ -0,0 +1,42 @@
+{- |
+Module     : Types
+Maintainer : emi@haskell.fyi
+Description: Param and script types for generation.
+
+Param and script types for generation.
+-}
+module Types (ScriptParams (..), AgoraScripts (..)) where
+
+import Agora.SafeMoney (GTTag)
+import Agora.ScriptInfo (PolicyInfo, ValidatorInfo)
+import Data.Aeson qualified as Aeson
+import Data.Tagged (Tagged)
+import GHC.Generics qualified as GHC
+import PlutusLedgerApi.V1 (TxOutRef)
+import PlutusLedgerApi.V1.Value (AssetClass)
+
+-- | Params required for creating script export.
+data ScriptParams where
+  ScriptParams ::
+    { governorInitialSpend :: TxOutRef
+    , gtClassRef :: Tagged GTTag AssetClass
+    , maximumCosigners :: Integer
+    } ->
+    ScriptParams
+  deriving anyclass (Aeson.ToJSON, Aeson.FromJSON)
+  deriving stock (Show, Eq, GHC.Generic, Ord)
+
+-- | Scripts that get exported.
+data AgoraScripts = AgoraScripts
+  { gitRev :: String
+  , governorPolicyInfo :: PolicyInfo
+  , governorValidatorInfo :: ValidatorInfo
+  , stakePolicyInfo :: PolicyInfo
+  , stakeValidatorInfo :: ValidatorInfo
+  , proposalPolicyInfo :: PolicyInfo
+  , proposalValidatorInfo :: ValidatorInfo
+  , treasuryValidatorInfo :: ValidatorInfo
+  , authorityTokenPolicyInfo :: PolicyInfo
+  }
+  deriving anyclass (Aeson.ToJSON, Aeson.FromJSON)
+  deriving stock (Show, Eq, GHC.Generic)

agora.cabal

@@ -235,18 +235,26 @@ executable agora-scripts
   main-is:        Scripts.hs
   hs-source-dirs: agora-scripts
   other-modules:
-    Options
     API
+    Codec.Serialise.Orphans
+    Data.Cache.Cached
+    Options
+    Types
+
   build-depends:
     , agora
+    , cache
+    , clock
     , gitrev
+    , hashable
+    , http-types
     , optparse-applicative
+    , prettyprinter
     , servant
     , servant-server
-    , warp
     , wai
-    , http-types
-    , prettyprinter
+    , wai-cors
+    , warp
 
 executable agora-purescript-bridge
   import:         lang, deps, exe-opts

flake.nix

@@ -140,11 +140,15 @@
       );
 
       applyDep = pkgs: o:
-        let h = myhackage pkgs.system o.compiler-nix-name; in
-        (plutarch.applyPlutarchDep pkgs o) // {
-          modules = haskellModules ++ [ h.module ] ++ (o.modules or [ ]);
-          extra-hackages = [ (import h.hackageNix) ] ++ (o.extra-hackages or [ ]);
-          extra-hackage-tarballs = { _xNJUd_plutarch-hackage = h.hackageTarball; } // (o.extra-hackage-tarballs or { });
+        let
+          h = myhackage pkgs.system o.compiler-nix-name;
+          o' = (plutarch.applyPlutarchDep pkgs o);
+        in
+        o' // rec {
+          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";
         };
 
       projectForGhc = compiler-nix-name: system: