{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- |Defines convenience functions to run a servant base api in wrap server
module Chakra.App
  ( module Chakra.App,
  )
where

import Control.Monad.Trans.Except (ExceptT (..))
import Data.Aeson
import Data.Proxy
import Network.Wai
import Network.Wai.Cli
import Network.Wai.Middleware.Health (health)
import Network.Wai.Middleware.Info (info)
import qualified Network.Wai.Middleware.Prometheus as P
import qualified Prometheus as P
import qualified Prometheus.Metric.GHC as P
import RIO
import Chakra.RequestLogging
import Servant as X hiding (And, Handler)
import qualified Servant
import qualified Chakra.Types as T (InfoDetail (..))
import Chakra.Util

-- | Setup servant with custom context so that the handers can take custom effects/ctx
chakraApp ::
  forall β χ ψ.
  ( HasServer χ ψ,
    HasContextEntry (ψ .++ DefaultErrorFormatters) ErrorFormatters
  ) =>
  -- |Servant Context e.g., EmptyContext
  Context ψ -> 
  -- |Application Has stacking in tuple type e.g., (ModLogger,ModHttpClient,UserRepo)
  β ->
  -- | Servant API Proxy
  Proxy χ ->
  -- | Servant api handlers in `RIO β` monad
  ServerT χ (RIO β) ->
  -- | Returns WAI compatiable Application so you can run using wrap
  Application
chakraApp :: Context ψ -> β -> Proxy χ -> ServerT χ (RIO β) -> Application
chakraApp Context ψ
sctx β
ctx Proxy χ
api ServerT χ (RIO β)
app = Proxy χ -> Context ψ -> Server χ -> Application
forall api (context :: [*]).
(HasServer api context,
 HasContextEntry
   (context .++ DefaultErrorFormatters) ErrorFormatters) =>
Proxy api -> Context context -> Server api -> Application
serveWithContext Proxy χ
api Context ψ
sctx (Server χ -> Application) -> Server χ -> Application
forall a b. (a -> b) -> a -> b
$ β -> Server χ
srv β
ctx
  where
    srv :: β -> Server χ
srv β
c = Proxy χ
-> Proxy ψ
-> (forall x. RIO β x -> Handler x)
-> ServerT χ (RIO β)
-> Server χ
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext Proxy χ
api (Proxy ψ
forall k (t :: k). Proxy t
Proxy @ψ) (β -> RIO β x -> Handler x
forall a h. a -> RIO a h -> Handler h
runChakraHandler β
c) ServerT χ (RIO β)
app

-- | Starts the warp server with given middlewares, context, api definition and api server
-- Does not enable/registers GHC internal metrics
runChakraApp ::
  ( MonadIO m,
    HasServer χ ψ,
    HasContextEntry (ψ .++ DefaultErrorFormatters) ErrorFormatters
  ) =>
  -- |WAI based middlewares
  Middleware ->
  -- |Servant Context e.g., EmptyContext
  Context ψ ->
  -- |Application Has stacking in tuple type e.g., (ModLogger,ModHttpClient,UserRepo)
  β ->
  -- | Servant API Proxy
  Proxy χ ->
  -- | Servant api handlers in `RIO β` monad
  ServerT χ (RIO β) ->
  -- Runs the resulting WAI application using wai-cli `defWaiMain` function
  m ()
runChakraApp :: Middleware
-> Context ψ -> β -> Proxy χ -> ServerT χ (RIO β) -> m ()
runChakraApp Middleware
middlewares Context ψ
sctx β
ctx Proxy χ
api ServerT χ (RIO β)
apiHandlers =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    Application -> IO ()
defWaiMain (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ Middleware
middlewares Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$ Context ψ -> β -> Proxy χ -> ServerT χ (RIO β) -> Application
forall β χ (ψ :: [*]).
(HasServer χ ψ,
 HasContextEntry (ψ .++ DefaultErrorFormatters) ErrorFormatters) =>
Context ψ -> β -> Proxy χ -> ServerT χ (RIO β) -> Application
chakraApp Context ψ
sctx β
ctx Proxy χ
api ServerT χ (RIO β)
apiHandlers

-- | Starts the warp server with given middlewares, context, api definition and api server
-- Enables prometheus metrics (with GHC internal metrics) (Needs -with-rtsopts=-T)
runChakraAppWithMetrics ::
  ( MonadIO m,
    HasServer χ ψ,
    HasContextEntry (ψ .++ DefaultErrorFormatters) ErrorFormatters
  ) =>
  -- |WAI based middlewares
  Middleware ->
  -- |Servant Context e.g., EmptyContext
  Context ψ ->
  -- |Application Has stacking in tuple type e.g., (ModLogger,ModHttpClient,UserRepo)
  β ->
  -- | Servant API Proxy
  Proxy χ ->
  -- | Servant api handlers in `RIO β` monad
  ServerT χ (RIO β) ->
  -- Runs the resulting WAI application using wai-cli `defWaiMain` function
  m ()
runChakraAppWithMetrics :: Middleware
-> Context ψ -> β -> Proxy χ -> ServerT χ (RIO β) -> m ()
runChakraAppWithMetrics Middleware
middlewares Context ψ
sctx β
ctx Proxy χ
api ServerT χ (RIO β)
apiHandlers = do
  GHCMetrics
_ <- m GHCMetrics
forall (m :: * -> *). MonadIO m => m GHCMetrics
registerMetrics
  Middleware
-> Context ψ -> β -> Proxy χ -> ServerT χ (RIO β) -> m ()
forall (m :: * -> *) χ (ψ :: [*]) β.
(MonadIO m, HasServer χ ψ,
 HasContextEntry (ψ .++ DefaultErrorFormatters) ErrorFormatters) =>
Middleware
-> Context ψ -> β -> Proxy χ -> ServerT χ (RIO β) -> m ()
runChakraApp Middleware
middlewares Context ψ
sctx β
ctx Proxy χ
api ServerT χ (RIO β)
apiHandlers

-- | Return default set of middlewares applied
chakraMiddlewares :: T.InfoDetail -> IO Middleware
chakraMiddlewares :: InfoDetail -> IO Middleware
chakraMiddlewares InfoDetail
infoDetail = do
  Middleware
logger <-
    Text -> Text -> IO Middleware
jsonRequestLogger (InfoDetail -> Text
T.appEnvironment InfoDetail
infoDetail) (InfoDetail -> Text
T.appVersion InfoDetail
infoDetail)
  Middleware -> IO Middleware
forall (m :: * -> *) a. Monad m => a -> m a
return (Middleware -> IO Middleware) -> Middleware -> IO Middleware
forall a b. (a -> b) -> a -> b
$ Middleware
logger Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrometheusSettings -> Middleware
P.prometheus PrometheusSettings
forall a. Default a => a
P.def Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Middleware
health Middleware -> Middleware -> Middleware
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Middleware
info ByteString
jsonInfoDetail
  where
    jsonInfoDetail :: ByteString
jsonInfoDetail = InfoDetail -> ByteString
forall a. ToJSON a => a -> ByteString
encode InfoDetail
infoDetail

-- | Registers GHC runtime metrics so that /metrics endpoint will return rich GHC info
-- Requires `-with-rtsopts=-T`
registerMetrics :: MonadIO m => m P.GHCMetrics
registerMetrics :: m GHCMetrics
registerMetrics = Metric GHCMetrics -> m GHCMetrics
forall (m :: * -> *) s. MonadIO m => Metric s -> m s
P.register Metric GHCMetrics
P.ghcMetrics

-- | Custom Servant Error formatter overrides to return in JSON format
chakraErrorFormatters :: ErrorFormatters
chakraErrorFormatters :: ErrorFormatters
chakraErrorFormatters =
  ErrorFormatters
defaultErrorFormatters
    { bodyParserErrorFormatter :: ErrorFormatter
bodyParserErrorFormatter = ErrorFormatter
jsonErrorFormatter,
      notFoundErrorFormatter :: NotFoundErrorFormatter
notFoundErrorFormatter = NotFoundErrorFormatter
notFoundFormatter
    }

-- | Natural transformation to run handlers in RIO monad instead of ServantT
runChakraHandler :: a -> RIO a h -> Servant.Handler h
runChakraHandler :: a -> RIO a h -> Handler h
runChakraHandler a
ctx RIO a h
a = ExceptT ServerError IO h -> Handler h
forall a. ExceptT ServerError IO a -> Handler a
Servant.Handler (ExceptT ServerError IO h -> Handler h)
-> ExceptT ServerError IO h -> Handler h
forall a b. (a -> b) -> a -> b
$ IO (Either ServerError h) -> ExceptT ServerError IO h
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ServerError h) -> ExceptT ServerError IO h)
-> IO (Either ServerError h) -> ExceptT ServerError IO h
forall a b. (a -> b) -> a -> b
$ IO h -> IO (Either ServerError h)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (IO h -> IO (Either ServerError h))
-> IO h -> IO (Either ServerError h)
forall a b. (a -> b) -> a -> b
$ ReaderT a IO h -> a -> IO h
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (RIO a h -> ReaderT a IO h
forall env a. RIO env a -> ReaderT env IO a
unRIO RIO a h
a) a
ctx