{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Com.MusicMeetsComics.Server.Config where

import           Com.MusicMeetsComics.Server.Logger
import           Control.Concurrent (ThreadId)
import           Control.Monad.Except (ExceptT, MonadError)
import           Control.Monad.IO.Class
import           Control.Monad.Logger (MonadLogger(..))
import           Control.Monad.Metrics (Metrics, MonadMetrics, getMetrics)
import qualified Control.Monad.Metrics as M
import           Control.Monad.Reader (MonadIO, MonadReader, ReaderT, asks)
import           Data.Text (pack)
import           GHC.Base (String)
import           Network.Wai (Middleware)
import           Network.Wai.Handler.Warp (Port)
import           Network.Wai.Middleware.RequestLogger (logStdout, logStdoutDev)
import           Protolude
import           Safe (readMay)
import           Servant (ServerError)
import           System.Environment (lookupEnv)
import           System.Remote.Monitoring (forkServer, serverMetricStore, serverThreadId)

-- | This type represents the effects we want to have for our application.
-- We wrap the standard Servant monad with 'ReaderT Config', which gives us
-- access to the application configuration using the 'MonadReader'
-- interface's 'ask' function.
--
-- By encapsulating the effects in our newtype, we can add layers to the
-- monad stack without having to modify code that uses the current layout.
newtype AppT m a = AppT
  { runApp :: ReaderT Config (ExceptT ServerError m) a
  } deriving ( Functor
             , Applicative
             , Monad
             , MonadReader Config
             , MonadError ServerError
             , MonadIO
             )

type App = AppT IO

-- | The Config for our application is (for now) the 'Environment' we're
-- running in and a Persistent 'ConnectionPool'.
data Config = Config
  { configEnv :: Environment
  , configMetrics :: Metrics
  , configEkgServer :: ThreadId
  , configLogEnv :: LogEnv
  , configPort :: Port
  }

instance Monad m => MonadMetrics (AppT m) where
  getMetrics = asks configMetrics

-- | Katip instance for @AppT m@
instance MonadIO m => Katip (AppT m) where
  getLogEnv = asks configLogEnv
  localLogEnv = panic "not implemented"

-- | MonadLogger instance to use within @AppT m@
instance MonadIO m => MonadLogger (AppT m) where
  monadLoggerLog = adapt logMsg

-- | MonadLogger instance to use in @makePool@
instance MonadIO m => MonadLogger (KatipT m) where
  monadLoggerLog = adapt logMsg

-- | Right now, we're distinguishing between three environments. We could
-- also add a @Staging@ environment if we needed to.
data Environment
  = Development
  | Test
  | Production
  deriving (Eq, Show, Read)

-- | This returns a 'Middleware' based on the environment that we're in.
setLogger :: Environment -> Middleware
setLogger Test = identity
setLogger Development = logStdoutDev
setLogger Production = logStdout

-- | Web request logger (currently unimplemented and unused). For inspiration
-- see ApacheLogger from wai-logger package.
katipLogger :: LogEnv -> Middleware
katipLogger env app req respond =
  runKatipT env $ do
    logMsg "web" InfoS "todo: received some request"
    -- todo: log proper request data
    liftIO $ app req respond

-- | The number of pools to use for a given environment.
envPool :: Environment -> Int
envPool Test = 1
envPool Development = 1
envPool Production = 8

-- | Allocates resources for 'Config'
acquire :: IO Config
acquire = do
  port <- lookupSetting "PORT" 3001
  env <- lookupSetting "ENV" Development
  logEnv <- defaultLogEnv
  ekgServer <- forkServer "localhost" 8000
  let store = serverMetricStore ekgServer
  metr <- M.initializeWith store
  pure
    Config
      { configEnv = env
      , configMetrics = metr
      , configLogEnv = logEnv
      , configPort = port
      , configEkgServer = serverThreadId ekgServer
      }

-- | Looks up a setting in the environment, with a provided default, and
-- 'read's that information into the inferred type.
lookupSetting :: Read a => String -> a -> IO a
lookupSetting env def_ = do
  maybeValue <- lookupEnv env
  case maybeValue of
    Nothing  -> return def_
    Just str -> maybe (handleFailedRead str) return (readMay str)
 where
  handleFailedRead str = panic
    $ mconcat ["Failed to read [[", pack str, "]] for environment variable ", pack env]