Initial commitHEADmaster

1 files changed, 88 insertions, 0 deletions

diff --git a/hsm-core/Hsm/Core/App.hs b/hsm-core/Hsm/Core/App.hs
new file mode 100644
index 0000000..1bb3465
--- /dev/null
+++ b/hsm-core/Hsm/Core/App.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+
+module Hsm.Core.App
+  ( launch
+  , launchWithEcho
+  )
+where
+
+import Control.Applicative ((<**>))
+import Data.Aeson (FromJSON, Result (Error, Success), Value, fromJSON)
+import Data.Aeson.Key (fromString)
+import Data.Aeson.KeyMap (KeyMap, (!?))
+import Data.Composition ((.:))
+import Data.Function.Slip (slipl)
+import Data.Maybe (fromMaybe)
+import Data.Text (pack, unpack)
+import Data.Yaml (decodeFileThrow)
+import Effectful.Log qualified as L
+import Log.Backend.StandardOutput (withStdOutLogger)
+import Options.Applicative qualified as P
+import System.IO.Echo (withoutInputEcho)
+
+data Options = Options String L.LogLevel
+
+type App e a = e -> L.Logger -> L.LogLevel -> IO a
+
+parser :: P.Parser Options
+parser = do
+  config <-
+    P.strOption $
+      P.help "Path to services config file"
+        <> P.short 'c'
+        <> P.long "config"
+        <> P.metavar "PATH"
+        <> P.value "config.yaml"
+        <> P.showDefault
+  level <-
+    P.option (P.eitherReader $ L.readLogLevelEither . pack) $
+      P.help "Log level"
+        <> P.short 'l'
+        <> P.long "log-level"
+        <> P.metavar "LEVEL"
+        <> P.value L.LogInfo
+        <> P.showDefaultWith (unpack . L.showLogLevel)
+  pure $ Options config level
+
+launchWith
+  :: forall e a
+   . FromJSON e
+  => String
+  -> App e a
+  -> (IO a -> IO a)
+  -> IO a
+launchWith name app wrapper = do
+  Options path level <- P.execParser info
+  returnEnv path >>= runApp level
+ where
+  title :: String
+  title = "Launch " <> name <> " service"
+
+  description :: P.InfoMod Options
+  description = P.fullDesc <> P.progDesc title
+
+  info :: P.ParserInfo Options
+  info = P.info (parser <**> P.helper) description
+
+  err :: String
+  err = "Service configuration for " <> name <> " not found"
+
+  load :: KeyMap Value -> Value
+  load configs = fromMaybe (error err) $ configs !? fromString name
+
+  check :: Result e -> e
+  check (Success e) = e
+  check (Error str) = error str
+
+  returnEnv :: String -> IO e
+  returnEnv = fmap (check . fromJSON . load) . decodeFileThrow
+
+  runApp :: L.LogLevel -> e -> IO a
+  runApp = wrapper . withStdOutLogger .: slipl app
+
+launch :: FromJSON e => String -> App e a -> IO a
+launch = slipl launchWith withoutInputEcho
+
+launchWithEcho :: FromJSON e => String -> App e a -> IO a
+launchWithEcho = slipl launchWith id