{-# 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