restructure agora-scripts modules

In order to allow reusing this code in the future, I've made it so that
Agora-specific code all lives in `Main`, and everything else lives in
`ScriptExport` or other non-Agora modules.

agora-scripts/ScriptExport/API.hs

@@ -0,0 +1,100 @@
+{- | 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 (cachedFor)
+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, runQuery)
+import ScriptExport.Types qualified as Builders
+import Servant.API (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 =
+  "query-script" :> ReqBody '[JSON] ScriptQuery :> Post '[JSON] Aeson.Value
+    :<|> "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 settings =
+        Warp.defaultSettings
+          & Warp.setPort options.port
+          & Warp.setLogger
+            ( \req status _maybeFileSize ->
+                putStrLn . renderString . layoutPretty defaultLayoutOptions $
+                  hsep
+                    [ "[info]"
+                    , viaShow $ Wai.requestMethod req
+                    , viaShow $ Wai.rawPathInfo req
+                    , "(" <> pretty (Http.statusCode status) <> ")"
+                    ]
+            )
+
+      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
+  query <- cachedFor (Just $ TimeSpec 300 0) (`runQuery` builders)
+
+  let serverInfo =
+        ServerInfo
+          { revision = revision
+          , exposedBuilders = Builders.toList builders
+          }
+
+  printf "[info] Running 'agora-scripts' on :%d\n" (Warp.getPort settings)
+  Servant.serve (Proxy @API) (query :<|> pure serverInfo)
+    & corsMiddleware
+    & Warp.runSettings settings

agora-scripts/ScriptExport/Options.hs

@@ -0,0 +1,39 @@
+{- |
+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
+
+newtype Options = Options
+  { port :: Warp.Port
+  }
+  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 path where the script configuration is."
+      )
+
+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

@@ -0,0 +1,94 @@
+{- |
+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.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
+
+{- | 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 -> Aeson.Value
+runQuery s =
+  maybe Aeson.Null ($ 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)
+  }
+
+-- | @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 f = Aeson.toJSON . \case { Aeson.Error _ -> Nothing; Aeson.Success v -> Just (f v) } . Aeson.fromJSON
+
+{- | Get a list of the available builders.
+
+     @since 0.2.0
+-}
+toList :: Builders -> [Text]
+toList = Map.keys . getBuilders