{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE NoPolyKinds #-}
module Yam(
start
, serveWarp
, AppConfig(..)
, AppT
, AppV
, AppIO
, AppSimple
, Simple
, runAppT
, runVault
, throwS
, AppMiddleware(..)
, emptyAM
, simpleContext
, simpleConfig
, simpleConfig'
, simpleMiddleware
, LogConfig(..)
, HasLogger
, LogFuncHolder
, VaultHolder
, Context(..)
, HasContextEntry(..)
, TryContextEntry(..)
, getEntry
, tryEntry
, SwaggerConfig(..)
, serveWithContextAndSwagger
, baseInfo
, spanNoNotifier
, Span(..)
, SpanContext(..)
, SpanTag(..)
, SpanReference(..)
, showText
, randomString
, randomCode
, decodeUtf8
, encodeUtf8
, pack
, liftIO
, fromMaybe
, throw
) where
import qualified Control.Category as C
import Control.Monad.Logger.CallStack
import Data.Opentracing
import Network.Wai
import Salak
import Servant
import Servant.Swagger
import Yam.App
import Yam.Config
import Yam.Logger
import Yam.Middleware.Error
import Yam.Middleware.Trace
import Yam.Prelude
import Yam.Swagger
newtype AppMiddleware a b = AppMiddleware
{ runAM :: Context a -> Middleware -> (Context b -> Middleware -> LoggingT IO ()) -> LoggingT IO () }
instance C.Category AppMiddleware where
id = AppMiddleware $ \a m f -> f a m
(AppMiddleware fbc) . (AppMiddleware fab) = AppMiddleware $ \a m f -> fab a m $ \b m1 -> fbc b m1 f
simpleContext :: a -> AppMiddleware cxt (a ': cxt)
simpleContext a = AppMiddleware $ \c m f -> f (a :. c) m
simpleConfig' :: (HasSalak cxt, FromProp a) => Text -> (a -> AppT cxt (LoggingT IO) b) -> AppMiddleware cxt (b ': cxt)
simpleConfig' key g = AppMiddleware $ \c m f -> runAppT c (require key) >>= \a -> runAppT c (g a) >>= \b -> f (b :. c) m
simpleConfig :: (HasSalak cxt, FromProp a) => Text -> AppMiddleware cxt (a ': cxt)
simpleConfig key = simpleConfig' key return
simpleMiddleware :: Middleware -> AppMiddleware cxt cxt
simpleMiddleware m = AppMiddleware $ \c m2 f -> f c (m . m2)
start
:: forall api cxt
. ( HasServer api cxt
, HasSwagger api)
=> AppConfig
-> SwaggerConfig
-> Version
-> IO LogConfig
-> (Span -> AppV cxt IO ())
-> AppMiddleware Simple cxt
-> (AppConfig -> Application -> IO ())
-> Proxy api
-> ServerT api (AppV cxt IO)
-> IO ()
start ac@AppConfig{..} sw@SwaggerConfig{..} vs logConfig f am runHttp p api =
withLogger name logConfig $ \logger -> do
logInfo $ "Start Service [" <> name <> "] ..."
let portText = showText port
baseCxt = LF logger :. EmptyContext
runAM am baseCxt id $ \cxt middleware -> do
when enabled $
logInfo $ "Swagger enabled: http://localhost:" <> portText <> "/" <> pack urlDir
logInfo $ "Servant started on port(s): " <> portText
liftIO
$ runHttp ac
$ traceMiddleware (\v -> runAppT (VH v :. cxt) . f)
$ middleware
$ errorMiddleware baseCxt
$ serveWithContextAndSwagger sw (baseInfo hostname name vs port) (Proxy @(Vault :> api)) cxt
$ \v -> hoistServerWithContext p (Proxy @cxt) (nt cxt v) api
serveWarp :: AppConfig -> Application -> IO ()
serveWarp AppConfig{..} = runSettings
$ defaultSettings
& setPort port
& setOnException (\_ _ -> return ())
& setOnExceptionResponse whenException
& setSlowlorisSize slowlorisSize
spanNoNotifier :: Span -> AppV cxt IO ()
spanNoNotifier _ = return ()
emptyAM :: AppMiddleware cxt cxt
emptyAM = C.id
type Simple = '[LogFuncHolder]
type AppSimple = AppV Simple IO