{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoFieldSelectors #-}

module WikiMusic.Boot where

import Control.Concurrent
import Control.Monad
import Data.Text qualified as T
import Database.Beam
import Network.Wai.Handler.Warp
import Network.Wai.Logger (ApacheLogger, withStdoutLogger)
import Optics
import Prometheus qualified as P
import Prometheus.Metric.GHC qualified as P
import Relude
import WikiMusic.Config
import WikiMusic.Model.Config
import WikiMusic.Servant.ApiSetup
import Yggdrasil

boot :: (MonadIO m) => m ()
boot :: forall (m :: * -> *). MonadIO m => m ()
boot = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (ApacheLogger -> IO ()) -> IO ()
forall a. (ApacheLogger -> IO a) -> IO a
withStdoutLogger ((ApacheLogger -> IO ()) -> IO ())
-> (ApacheLogger -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ApacheLogger
logger' ->
  ( do
      GHCMetrics
_ <- IO GHCMetrics -> IO GHCMetrics
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GHCMetrics -> IO GHCMetrics) -> IO GHCMetrics -> IO GHCMetrics
forall a b. (a -> b) -> a -> b
$ Metric GHCMetrics -> IO GHCMetrics
forall (m :: * -> *) s. MonadIO m => Metric s -> m s
P.register Metric GHCMetrics
P.ghcMetrics
      [String]
args <- IO [String] -> IO [String]
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [String]
forall (m :: * -> *). MonadIO m => m [String]
getArgs
      Either Text AppConfig
maybeCfg <- Text -> IO (Either Text AppConfig)
forall (m :: * -> *).
MonadIO m =>
Text -> m (Either Text AppConfig)
readConfig ([String] -> Text
configPathFromArgs [String]
args)
      IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Text -> IO ())
-> (AppConfig -> IO ()) -> Either Text AppConfig -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> IO ()
forall {a} {a}. Show a => a -> a
crashWithBadConfig (ApacheLogger -> AppConfig -> IO ()
doRun ApacheLogger
logger') Either Text AppConfig
maybeCfg
  )
  where
    crashWithBadConfig :: a -> a
crashWithBadConfig a
e = Text -> a
forall a t. (HasCallStack, IsText t) => t -> a
error (Text
"Bad config could not be parsed! " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall b a. (Show a, IsString b) => a -> b
show a
e)
    doRun :: ApacheLogger -> AppConfig -> IO ()
doRun ApacheLogger
logger' AppConfig
cfg = do
      IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> (Text -> IO ()) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putText (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Starting Yggdrasil migrations ..."
      ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Yggdrasil -> IO ()
forall (m :: * -> *). MonadIO m => Yggdrasil -> m ()
runYggdrasil (AppConfig -> Yggdrasil
forall {k} {l} {k} {u} {v} {s}.
(JoinKinds k l k, Is k A_Getter, LabelOptic "path" l u v Text Text,
 LabelOptic "sqlite" k s s u v) =>
s -> Yggdrasil
yggdrasil AppConfig
cfg)
      ()
_ <- ApacheLogger -> AppConfig -> IO ()
forall (m :: * -> *).
MonadIO m =>
ApacheLogger -> AppConfig -> m ()
startWikiMusicAPI ApacheLogger
logger' AppConfig
cfg
      () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    yggdrasil :: s -> Yggdrasil
yggdrasil s
cfg =
      Yggdrasil
        { $sel:databaseFilePath:Yggdrasil :: Text
databaseFilePath = s
cfg s -> Optic' k NoIx s Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic k NoIx s s u v
#sqlite Optic k NoIx s s u v
-> Optic l NoIx u v Text Text -> Optic' k NoIx s Text
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic l NoIx u v Text Text
#path,
          $sel:migrationsDirectoryPath:Yggdrasil :: Text
migrationsDirectoryPath = Text
"./resources/migrations/sqlite/",
          $sel:runMigrations:Yggdrasil :: Bool
runMigrations = Bool
True,
          $sel:engine:Yggdrasil :: YggdrasilEngine
engine = YggdrasilEngine
SQLite
        }
    configPathFromArgs :: [String] -> Text
configPathFromArgs [String]
args = case [String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [String]
args of
      Just (String
x :| []) -> String -> Text
T.pack String
x
      Maybe (NonEmpty String)
_ -> Text
"resources/config/run-local.toml"

startWikiMusicAPI :: (MonadIO m) => ApacheLogger -> AppConfig -> m ()
startWikiMusicAPI :: forall (m :: * -> *).
MonadIO m =>
ApacheLogger -> AppConfig -> m ()
startWikiMusicAPI ApacheLogger
logger' AppConfig
cfg = do
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Text -> IO ()) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putText (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Starting REST API ..."
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Settings -> Application -> IO ()
runSettings Settings
apiSettings (Application -> IO ()) -> IO Application -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ApacheLogger -> AppConfig -> IO Application
forall (m :: * -> *).
MonadIO m =>
ApacheLogger -> AppConfig -> m Application
mkApp ApacheLogger
logger' AppConfig
cfg
  where
    apiSettings :: Settings
apiSettings = Port -> Settings -> Settings
setPort (AppConfig
cfg AppConfig -> Optic' A_Lens NoIx AppConfig Port -> Port
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic A_Lens NoIx AppConfig AppConfig ServantConfig ServantConfig
#servant Optic A_Lens NoIx AppConfig AppConfig ServantConfig ServantConfig
-> Optic A_Lens NoIx ServantConfig ServantConfig Port Port
-> Optic' A_Lens NoIx AppConfig Port
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx ServantConfig ServantConfig Port Port
#port) Settings
defaultSettings