{-# LANGUAGE PolyKinds #-}
module Servant.Util.Combinators.Logging
(
LoggingApi
, LoggingApiRec
, LoggingMod
, LoggingLevel
, LoggingRequestsEnabled
, LoggingRequestsDisabled
, LoggingResponsesEnabled
, LoggingResponsesDisabled
, LoggingDisabled
, LogContext (..)
, HasLoggingServer (..)
, ServantLogConfig (..)
, ForResponseLog (..)
, BuildableForResponseIfNecessary
, buildListForResponse
, buildForResponse
, ApiHasArgClass (..)
, ApiCanLogArg (..)
, addParamLogInfo
, setInPrefix
, serverWithLogging
) where
import Universum
import Control.Monad.Error.Class (catchError, throwError)
import Data.Constraint (Dict (..))
import Data.Default (Default (..))
import Data.Reflection (Reifies (..), reify)
import Data.Swagger (Swagger)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Fmt (Buildable (..), Builder, blockListF, pretty, (+|), (|+), (||+))
import GHC.IO.Unsafe (unsafePerformIO)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Servant.API (Capture, Description, NoContent, NoContentVerb, QueryFlag, QueryParam', Raw,
ReflectMethod (..), ReqBody, SBoolI, Summary, Verb, (:<|>) (..), (:>))
import Servant.API.Modifiers (FoldRequired, foldRequiredArgument)
import Servant.Client (HasClient (..))
import Servant.Server (Handler (..), HasServer (..), Server, ServerError (..))
import Servant.Swagger (HasSwagger (..))
import Servant.Swagger.UI.Core (SwaggerUiHtml)
import System.Console.Pretty (Color (..), Style (..), color, style)
import qualified Data.Text as T
import qualified Servant.Server.Internal as SI
import Servant.Util.Common
data LoggingApi config api
data LoggingApiRec config (lcontext :: LoggingContext) api
data LoggingContext = LoggingContext
(Maybe Nat)
Bool
Bool
type family EmptyLoggingContext :: LoggingContext where
EmptyLoggingContext = 'LoggingContext 'Nothing 'True 'True
type family LcResponsesEnabled (lcontext :: LoggingContext) :: Bool where
LcResponsesEnabled ('LoggingContext _ _ flag) = flag
type BuildableForResponseIfNecessary lcontext resp =
( If (LcResponsesEnabled lcontext)
(Buildable (ForResponseLog resp))
(() :: Constraint)
, Demote (LcResponsesEnabled lcontext)
)
data LoggingMod (mod :: LoggingModKind)
data LoggingModKind
= LMLoggingLevel Nat
| LMRequestsLogged Bool
| LMResponsesLogged Bool
| LMLoggingDisabled
type LoggingLevel lvl = LoggingMod ('LMLoggingLevel lvl)
type LoggingRequestsDisabled = LoggingMod ('LMRequestsLogged 'False)
type LoggingRequestsEnabled = LoggingMod ('LMRequestsLogged 'True)
type LoggingResponsesDisabled = LoggingMod ('LMResponsesLogged 'False)
type LoggingResponsesEnabled = LoggingMod ('LMResponsesLogged 'True)
type LoggingDisabled = LoggingMod 'LMLoggingDisabled
data LogFullContext = LogFullContext
{ LogFullContext -> Maybe Natural
lcRecommendedLevel :: Maybe Natural
, LogFullContext -> Bool
lcRequestsEnabled :: Bool
, LogFullContext -> Bool
lcResponsesEnabled :: Bool
} deriving (Int -> LogFullContext -> ShowS
[LogFullContext] -> ShowS
LogFullContext -> String
(Int -> LogFullContext -> ShowS)
-> (LogFullContext -> String)
-> ([LogFullContext] -> ShowS)
-> Show LogFullContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogFullContext] -> ShowS
$cshowList :: [LogFullContext] -> ShowS
show :: LogFullContext -> String
$cshow :: LogFullContext -> String
showsPrec :: Int -> LogFullContext -> ShowS
$cshowsPrec :: Int -> LogFullContext -> ShowS
Show)
type instance Demoted LoggingContext = LogFullContext
instance ( ctx ~ 'LoggingContext lvl req resp
, Demote lvl
, Demote req
, Demote resp
) => Demote ctx where
demote :: Proxy ctx -> Demoted LoggingContext
demote Proxy ctx
_ = LogFullContext :: Maybe Natural -> Bool -> Bool -> LogFullContext
LogFullContext
{ lcRecommendedLevel :: Maybe Natural
lcRecommendedLevel = Proxy lvl -> Demoted (Maybe Nat)
forall k (ty :: k). Demote ty => Proxy ty -> Demoted k
demote (Proxy lvl
forall k (t :: k). Proxy t
Proxy @lvl)
, lcRequestsEnabled :: Bool
lcRequestsEnabled = Proxy req -> Demoted Bool
forall k (ty :: k). Demote ty => Proxy ty -> Demoted k
demote (Proxy req
forall k (t :: k). Proxy t
Proxy @req)
, lcResponsesEnabled :: Bool
lcResponsesEnabled = Proxy resp -> Demoted Bool
forall k (ty :: k). Demote ty => Proxy ty -> Demoted k
demote (Proxy resp
forall k (t :: k). Proxy t
Proxy @resp)
}
type family ApplyLoggingMod (lcontext :: LoggingContext) (mod :: LoggingModKind) where
ApplyLoggingMod ('LoggingContext _ req resp) ('LMLoggingLevel lvl) =
'LoggingContext ('Just lvl) req resp
ApplyLoggingMod ('LoggingContext mlvl _ resp) ('LMRequestsLogged req) =
'LoggingContext mlvl req resp
ApplyLoggingMod ('LoggingContext mlvl req _) ('LMResponsesLogged resp) =
'LoggingContext mlvl req resp
ApplyLoggingMod ('LoggingContext mlvl _ _) 'LMLoggingDisabled =
'LoggingContext mlvl 'False 'False
newtype LogContext = LogContext
{ LogContext -> Maybe Natural
lecRecommendedLevel :: Maybe Natural
} deriving (Int -> LogContext -> ShowS
[LogContext] -> ShowS
LogContext -> String
(Int -> LogContext -> ShowS)
-> (LogContext -> String)
-> ([LogContext] -> ShowS)
-> Show LogContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogContext] -> ShowS
$cshowList :: [LogContext] -> ShowS
show :: LogContext -> String
$cshow :: LogContext -> String
showsPrec :: Int -> LogContext -> ShowS
$cshowsPrec :: Int -> LogContext -> ShowS
Show, LogContext -> LogContext -> Bool
(LogContext -> LogContext -> Bool)
-> (LogContext -> LogContext -> Bool) -> Eq LogContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogContext -> LogContext -> Bool
$c/= :: LogContext -> LogContext -> Bool
== :: LogContext -> LogContext -> Bool
$c== :: LogContext -> LogContext -> Bool
Eq)
newtype ServantLogConfig = ServantLogConfig
{ ServantLogConfig -> LogContext -> Text -> IO ()
clcLog :: LogContext -> Text -> IO ()
}
dullColor :: Color -> Text -> Text
dullColor :: Color -> Text -> Text
dullColor Color
c = Style -> Text -> Text
forall a. Pretty a => Style -> a -> a
style Style
Faint (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Color -> Text -> Text
forall a. Pretty a => Color -> a -> a
color Color
c
gray :: Text -> Text
gray :: Text -> Text
gray = Color -> Text -> Text
dullColor Color
White
data ApiParamsLogInfo
= ApiParamsLogInfo Bool [Text] [Text]
| ApiNoParamsLogInfo Text
instance Default ApiParamsLogInfo where
def :: ApiParamsLogInfo
def = Bool -> [Text] -> [Text] -> ApiParamsLogInfo
ApiParamsLogInfo Bool
False [] []
addParamLogInfo :: Text -> ApiParamsLogInfo -> ApiParamsLogInfo
addParamLogInfo :: Text -> ApiParamsLogInfo -> ApiParamsLogInfo
addParamLogInfo Text
_ failed :: ApiParamsLogInfo
failed@ApiNoParamsLogInfo{} = ApiParamsLogInfo
failed
addParamLogInfo Text
paramInfo (ApiParamsLogInfo Bool
False [Text]
path []) =
Bool -> [Text] -> [Text] -> ApiParamsLogInfo
ApiParamsLogInfo Bool
False (Text
paramInfo Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
path) []
addParamLogInfo Text
paramInfo (ApiParamsLogInfo Bool
inPrefix [Text]
path [Text]
infos) =
Bool -> [Text] -> [Text] -> ApiParamsLogInfo
ApiParamsLogInfo Bool
inPrefix [Text]
path (Text
paramInfo Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
infos)
setInPrefix :: ApiParamsLogInfo -> ApiParamsLogInfo
setInPrefix :: ApiParamsLogInfo -> ApiParamsLogInfo
setInPrefix failed :: ApiParamsLogInfo
failed@ApiNoParamsLogInfo{} = ApiParamsLogInfo
failed
setInPrefix infos :: ApiParamsLogInfo
infos@(ApiParamsLogInfo Bool
_ [] [Text]
_) = ApiParamsLogInfo
infos
setInPrefix (ApiParamsLogInfo Bool
_ [Text]
path [Text]
info) = Bool -> [Text] -> [Text] -> ApiParamsLogInfo
ApiParamsLogInfo Bool
True [Text]
path [Text]
info
newtype ForResponseLog a = ForResponseLog { ForResponseLog a -> a
unForResponseLog :: a }
buildListForResponse
:: Buildable (ForResponseLog x)
=> (forall a. [a] -> [a]) -> ForResponseLog [x] -> Builder
buildListForResponse :: (forall a. [a] -> [a]) -> ForResponseLog [x] -> Builder
buildListForResponse forall a. [a] -> [a]
truncList (ForResponseLog [x]
l) =
let startNf :: Builder
startNf = if [x] -> Bool
forall t. Container t => t -> Bool
null [x]
l then Builder
"" else Builder
"\n"
lt :: [x]
lt = [x] -> [x]
forall a. [a] -> [a]
truncList [x]
l
diff :: Int
diff = [x] -> Int
forall t. Container t => t -> Int
length [x]
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- [x] -> Int
forall t. Container t => t -> Int
length [x]
lt
mMore :: Builder
mMore | Int
diff Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Builder
""
| Bool
otherwise = Builder
"\n and " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Int
diff Int -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" entries more..."
in Builder
startNf Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| [ForResponseLog x] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
blockListF ((x -> ForResponseLog x) -> [x] -> [ForResponseLog x]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map x -> ForResponseLog x
forall a. a -> ForResponseLog a
ForResponseLog [x]
lt) Builder -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
mMore
buildForResponse :: Buildable a => ForResponseLog a -> Builder
buildForResponse :: ForResponseLog a -> Builder
buildForResponse = a -> Builder
forall p. Buildable p => p -> Builder
build (a -> Builder)
-> (ForResponseLog a -> a) -> ForResponseLog a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForResponseLog a -> a
forall a. ForResponseLog a -> a
unForResponseLog
instance ( HasServer (LoggingApiRec config EmptyLoggingContext api) ctx
, HasServer api ctx
) =>
HasServer (LoggingApi config api) ctx where
type ServerT (LoggingApi config api) m = ServerT api m
route :: Proxy (LoggingApi config api)
-> Context ctx
-> Delayed env (Server (LoggingApi config api))
-> Router env
route = (Proxy (LoggingApiRec config EmptyLoggingContext api)
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config EmptyLoggingContext api))
-> Router env)
-> (Server (LoggingApi config api)
-> Server (LoggingApiRec config EmptyLoggingContext api))
-> Proxy (LoggingApi config api)
-> Context ctx
-> Delayed env (Server (LoggingApi config api))
-> Router env
forall api api' (ctx :: [*]) env.
(Proxy api
-> Context ctx -> Delayed env (Server api) -> Router env)
-> (Server api' -> Server api)
-> Proxy api'
-> Context ctx
-> Delayed env (Server api')
-> Router env
inRouteServer @(LoggingApiRec config EmptyLoggingContext api) Proxy (LoggingApiRec config EmptyLoggingContext api)
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config EmptyLoggingContext api))
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route
(ApiParamsLogInfo
forall a. Default a => a
def, )
hoistServerWithContext :: Proxy (LoggingApi config api)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (LoggingApi config api) m
-> ServerT (LoggingApi config api) n
hoistServerWithContext Proxy (LoggingApi config api)
_ = Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
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
forall k (t :: k). Proxy t
Proxy :: Proxy api)
class HasServer api ctx => HasLoggingServer config (lcontext :: LoggingContext) api ctx where
routeWithLog
:: Proxy (LoggingApiRec config lcontext api)
-> SI.Context ctx
-> SI.Delayed env (Server (LoggingApiRec config lcontext api))
-> SI.Router env
instance HasLoggingServer config lcontext api ctx =>
HasServer (LoggingApiRec config lcontext api) ctx where
type ServerT (LoggingApiRec config lcontext api) m =
(ApiParamsLogInfo, ServerT api m)
route :: Proxy (LoggingApiRec config lcontext api)
-> Context ctx
-> Delayed env (Server (LoggingApiRec config lcontext api))
-> Router env
route = Proxy (LoggingApiRec config lcontext api)
-> Context ctx
-> Delayed env (Server (LoggingApiRec config lcontext api))
-> Router env
forall k k (config :: k) (lcontext :: LoggingContext) (api :: k)
(ctx :: [*]) env.
HasLoggingServer config lcontext api ctx =>
Proxy (LoggingApiRec config lcontext api)
-> Context ctx
-> Delayed env (Server (LoggingApiRec config lcontext api))
-> Router env
routeWithLog
hoistServerWithContext :: Proxy (LoggingApiRec config lcontext api)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (LoggingApiRec config lcontext api) m
-> ServerT (LoggingApiRec config lcontext api) n
hoistServerWithContext Proxy (LoggingApiRec config lcontext api)
_ Proxy ctx
pc forall x. m x -> n x
nt ServerT (LoggingApiRec config lcontext api) m
s =
Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
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
forall k (t :: k). Proxy t
Proxy :: Proxy api) Proxy ctx
pc forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (ApiParamsLogInfo, ServerT api m)
-> (ApiParamsLogInfo, ServerT api n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ApiParamsLogInfo, ServerT api m)
ServerT (LoggingApiRec config lcontext api) m
s
instance ( HasLoggingServer config lcontext api1 ctx
, HasLoggingServer config lcontext api2 ctx
) =>
HasLoggingServer config lcontext (api1 :<|> api2) ctx where
routeWithLog :: Proxy (LoggingApiRec config lcontext (api1 :<|> api2))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (api1 :<|> api2)))
-> Router env
routeWithLog =
(Proxy
(LoggingApiRec config lcontext api1
:<|> LoggingApiRec config lcontext api2)
-> Context ctx
-> Delayed
env
(Server
(LoggingApiRec config lcontext api1
:<|> LoggingApiRec config lcontext api2))
-> Router env)
-> (Server (LoggingApiRec config lcontext (api1 :<|> api2))
-> Server
(LoggingApiRec config lcontext api1
:<|> LoggingApiRec config lcontext api2))
-> Proxy (LoggingApiRec config lcontext (api1 :<|> api2))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (api1 :<|> api2)))
-> Router env
forall api api' (ctx :: [*]) env.
(Proxy api
-> Context ctx -> Delayed env (Server api) -> Router env)
-> (Server api' -> Server api)
-> Proxy api'
-> Context ctx
-> Delayed env (Server api')
-> Router env
inRouteServer
@(LoggingApiRec config lcontext api1 :<|> LoggingApiRec config lcontext api2)
Proxy
(LoggingApiRec config lcontext api1
:<|> LoggingApiRec config lcontext api2)
-> Context ctx
-> Delayed
env
(Server
(LoggingApiRec config lcontext api1
:<|> LoggingApiRec config lcontext api2))
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route ((Server (LoggingApiRec config lcontext (api1 :<|> api2))
-> Server
(LoggingApiRec config lcontext api1
:<|> LoggingApiRec config lcontext api2))
-> Proxy (LoggingApiRec config lcontext (api1 :<|> api2))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (api1 :<|> api2)))
-> Router env)
-> (Server (LoggingApiRec config lcontext (api1 :<|> api2))
-> Server
(LoggingApiRec config lcontext api1
:<|> LoggingApiRec config lcontext api2))
-> Proxy (LoggingApiRec config lcontext (api1 :<|> api2))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (api1 :<|> api2)))
-> Router env
forall a b. (a -> b) -> a -> b
$
\(paramsInfo, f1 :<|> f2) ->
let paramsInfo' :: ApiParamsLogInfo
paramsInfo' = ApiParamsLogInfo -> ApiParamsLogInfo
setInPrefix ApiParamsLogInfo
paramsInfo
in (ApiParamsLogInfo
paramsInfo', ServerT api1 Handler
f1) (ApiParamsLogInfo, ServerT api1 Handler)
-> (ApiParamsLogInfo, ServerT api2 Handler)
-> (ApiParamsLogInfo, ServerT api1 Handler)
:<|> (ApiParamsLogInfo, ServerT api2 Handler)
forall a b. a -> b -> a :<|> b
:<|> (ApiParamsLogInfo
paramsInfo', ServerT api2 Handler
f2)
instance ( KnownSymbol path
, HasLoggingServer config lcontext res ctx
) =>
HasLoggingServer config lcontext (path :> res) ctx where
routeWithLog :: Proxy (LoggingApiRec config lcontext (path :> res))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (path :> res)))
-> Router env
routeWithLog =
(Proxy (path :> LoggingApiRec config lcontext res)
-> Context ctx
-> Delayed env (Server (path :> LoggingApiRec config lcontext res))
-> Router env)
-> (Server (LoggingApiRec config lcontext (path :> res))
-> Server (path :> LoggingApiRec config lcontext res))
-> Proxy (LoggingApiRec config lcontext (path :> res))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (path :> res)))
-> Router env
forall api api' (ctx :: [*]) env.
(Proxy api
-> Context ctx -> Delayed env (Server api) -> Router env)
-> (Server api' -> Server api)
-> Proxy api'
-> Context ctx
-> Delayed env (Server api')
-> Router env
inRouteServer @(path :> LoggingApiRec config lcontext res) Proxy (path :> LoggingApiRec config lcontext res)
-> Context ctx
-> Delayed env (Server (path :> LoggingApiRec config lcontext res))
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route ((Server (LoggingApiRec config lcontext (path :> res))
-> Server (path :> LoggingApiRec config lcontext res))
-> Proxy (LoggingApiRec config lcontext (path :> res))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (path :> res)))
-> Router env)
-> (Server (LoggingApiRec config lcontext (path :> res))
-> Server (path :> LoggingApiRec config lcontext res))
-> Proxy (LoggingApiRec config lcontext (path :> res))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (path :> res)))
-> Router env
forall a b. (a -> b) -> a -> b
$
(ApiParamsLogInfo -> ApiParamsLogInfo)
-> (ApiParamsLogInfo, ServerT res Handler)
-> (ApiParamsLogInfo, ServerT res Handler)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ApiParamsLogInfo -> ApiParamsLogInfo
updateParamsInfo
where
updateParamsInfo :: ApiParamsLogInfo -> ApiParamsLogInfo
updateParamsInfo =
let path :: Text
path = String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> (Proxy path -> String) -> Proxy path -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy path -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy path -> Text) -> Proxy path -> Text
forall a b. (a -> b) -> a -> b
$ Proxy path
forall k (t :: k). Proxy t
Proxy @path
in Text -> ApiParamsLogInfo -> ApiParamsLogInfo
addParamLogInfo Text
path
class ApiHasArgClass subApi =>
ApiCanLogArg subApi where
type ApiArgToLog subApi :: Type
type ApiArgToLog subApi = ApiArg subApi
toLogParamInfo
:: Buildable (ApiArgToLog subApi)
=> Proxy subApi -> ApiArg subApi -> Text
default toLogParamInfo
:: Buildable (ApiArg subApi)
=> Proxy subApi -> ApiArg subApi -> Text
toLogParamInfo Proxy subApi
_ ApiArg subApi
param = ApiArg subApi -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty ApiArg subApi
param
instance KnownSymbol s => ApiCanLogArg (Capture s a)
instance ApiCanLogArg (ReqBody ct a)
instance ( Buildable a
, KnownSymbol cs
, SBoolI (FoldRequired mods)
) =>
ApiCanLogArg (QueryParam' mods cs a) where
type ApiArgToLog (QueryParam' mods cs a) = a
toLogParamInfo :: Proxy (QueryParam' mods cs a)
-> ApiArg (QueryParam' mods cs a) -> Text
toLogParamInfo Proxy (QueryParam' mods cs a)
_ ApiArg (QueryParam' mods cs a)
mparam = Proxy mods
-> (a -> Text)
-> (Maybe a -> Text)
-> RequiredArgument mods a
-> Text
forall (mods :: [*]) a r.
SBoolI (FoldRequired mods) =>
Proxy mods
-> (a -> r) -> (Maybe a -> r) -> RequiredArgument mods a -> r
foldRequiredArgument (Proxy mods
forall k (t :: k). Proxy t
Proxy :: Proxy mods) (\(a
a :: a) -> a -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty a
a)
(\case
Just a
a -> a -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty a
a
Maybe a
Nothing -> Text
noEntry) RequiredArgument mods a
ApiArg (QueryParam' mods cs a)
mparam
where
noEntry :: Text
noEntry = Text -> Text
gray Text
"-"
instance KnownSymbol cs => ApiCanLogArg (QueryFlag cs) where
type ApiArgToLog (QueryFlag cs) = Bool
paramRouteWithLog
:: forall config lcontext api subApi res ctx env.
( api ~ (subApi :> res)
, HasServer (subApi :> LoggingApiRec config lcontext res) ctx
, ApiHasArg subApi res
, ApiHasArg subApi (LoggingApiRec config lcontext res)
, ApiCanLogArg subApi
, Buildable (ApiArgToLog subApi)
)
=> Proxy (LoggingApiRec config lcontext api)
-> SI.Context ctx
-> SI.Delayed env (Server (LoggingApiRec config lcontext api))
-> SI.Router env
paramRouteWithLog :: Proxy (LoggingApiRec config lcontext api)
-> Context ctx
-> Delayed env (Server (LoggingApiRec config lcontext api))
-> Router env
paramRouteWithLog =
(Proxy (subApi :> LoggingApiRec config lcontext res)
-> Context ctx
-> Delayed
env (Server (subApi :> LoggingApiRec config lcontext res))
-> Router env)
-> (Server (LoggingApiRec config lcontext api)
-> Server (subApi :> LoggingApiRec config lcontext res))
-> Proxy (LoggingApiRec config lcontext api)
-> Context ctx
-> Delayed env (Server (LoggingApiRec config lcontext api))
-> Router env
forall api api' (ctx :: [*]) env.
(Proxy api
-> Context ctx -> Delayed env (Server api) -> Router env)
-> (Server api' -> Server api)
-> Proxy api'
-> Context ctx
-> Delayed env (Server api')
-> Router env
inRouteServer @(subApi :> LoggingApiRec config lcontext res) Proxy (subApi :> LoggingApiRec config lcontext res)
-> Context ctx
-> Delayed
env (Server (subApi :> LoggingApiRec config lcontext res))
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route ((Server (LoggingApiRec config lcontext api)
-> Server (subApi :> LoggingApiRec config lcontext res))
-> Proxy (LoggingApiRec config lcontext api)
-> Context ctx
-> Delayed env (Server (LoggingApiRec config lcontext api))
-> Router env)
-> (Server (LoggingApiRec config lcontext api)
-> Server (subApi :> LoggingApiRec config lcontext res))
-> Proxy (LoggingApiRec config lcontext api)
-> Context ctx
-> Delayed env (Server (LoggingApiRec config lcontext api))
-> Router env
forall a b. (a -> b) -> a -> b
$
\(paramsInfo, f) ApiArg subApi
a -> (ApiArg subApi
a ApiArg subApi -> ApiParamsLogInfo -> ApiParamsLogInfo
`updateParamsInfo` ApiParamsLogInfo
paramsInfo, ApiArg subApi -> ServerT res Handler
f ApiArg subApi
a)
where
updateParamsInfo :: ApiArg subApi -> ApiParamsLogInfo -> ApiParamsLogInfo
updateParamsInfo ApiArg subApi
a =
let paramVal :: Text
paramVal = Proxy subApi -> ApiArg subApi -> Text
forall subApi.
(ApiCanLogArg subApi, Buildable (ApiArgToLog subApi)) =>
Proxy subApi -> ApiArg subApi -> Text
toLogParamInfo (Proxy subApi
forall k (t :: k). Proxy t
Proxy @subApi) ApiArg subApi
a
paramName :: String
paramName = Proxy subApi -> String
forall api. ApiHasArgClass api => Proxy api -> String
apiArgName (Proxy subApi -> String) -> Proxy subApi -> String
forall a b. (a -> b) -> a -> b
$ Proxy subApi
forall k (t :: k). Proxy t
Proxy @subApi
paramInfo :: Text
paramInfo = String
paramName String -> Builder -> Text
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
": " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Text
paramVal Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
in Text -> ApiParamsLogInfo -> ApiParamsLogInfo
addParamLogInfo Text
paramInfo (ApiParamsLogInfo -> ApiParamsLogInfo)
-> (ApiParamsLogInfo -> ApiParamsLogInfo)
-> ApiParamsLogInfo
-> ApiParamsLogInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApiParamsLogInfo -> ApiParamsLogInfo
setInPrefix
instance ( HasServer (subApi :> res) ctx
, HasServer (subApi :> LoggingApiRec config lcontext res) ctx
, ApiHasArg subApi res
, ApiHasArg subApi (LoggingApiRec config lcontext res)
, ApiCanLogArg subApi
, Buildable (ApiArgToLog subApi)
, subApi ~ apiType (a :: Type)
) =>
HasLoggingServer config lcontext (apiType a :> res) ctx where
routeWithLog :: Proxy (LoggingApiRec config lcontext (apiType a :> res))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (apiType a :> res)))
-> Router env
routeWithLog = Proxy (LoggingApiRec config lcontext (apiType a :> res))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (apiType a :> res)))
-> Router env
forall k (config :: k) (lcontext :: LoggingContext) api subApi res
(ctx :: [*]) env.
(api ~ (subApi :> res),
HasServer (subApi :> LoggingApiRec config lcontext res) ctx,
ApiHasArg subApi res,
ApiHasArg subApi (LoggingApiRec config lcontext res),
ApiCanLogArg subApi, Buildable (ApiArgToLog subApi)) =>
Proxy (LoggingApiRec config lcontext api)
-> Context ctx
-> Delayed env (Server (LoggingApiRec config lcontext api))
-> Router env
paramRouteWithLog
instance ( HasLoggingServer config lcontext res ctx
, KnownSymbol s
) =>
HasLoggingServer config lcontext (QueryFlag s :> res) ctx where
routeWithLog :: Proxy (LoggingApiRec config lcontext (QueryFlag s :> res))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (QueryFlag s :> res)))
-> Router env
routeWithLog = Proxy (LoggingApiRec config lcontext (QueryFlag s :> res))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (QueryFlag s :> res)))
-> Router env
forall k (config :: k) (lcontext :: LoggingContext) api subApi res
(ctx :: [*]) env.
(api ~ (subApi :> res),
HasServer (subApi :> LoggingApiRec config lcontext res) ctx,
ApiHasArg subApi res,
ApiHasArg subApi (LoggingApiRec config lcontext res),
ApiCanLogArg subApi, Buildable (ApiArgToLog subApi)) =>
Proxy (LoggingApiRec config lcontext api)
-> Context ctx
-> Delayed env (Server (LoggingApiRec config lcontext api))
-> Router env
paramRouteWithLog
instance HasLoggingServer config lcontext res ctx =>
HasLoggingServer config lcontext (Summary s :> res) ctx where
routeWithLog :: Proxy (LoggingApiRec config lcontext (Summary s :> res))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (Summary s :> res)))
-> Router env
routeWithLog = (Proxy (Summary s :> LoggingApiRec config lcontext res)
-> Context ctx
-> Delayed
env (Server (Summary s :> LoggingApiRec config lcontext res))
-> Router env)
-> (Server (LoggingApiRec config lcontext (Summary s :> res))
-> Server (Summary s :> LoggingApiRec config lcontext res))
-> Proxy (LoggingApiRec config lcontext (Summary s :> res))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (Summary s :> res)))
-> Router env
forall api api' (ctx :: [*]) env.
(Proxy api
-> Context ctx -> Delayed env (Server api) -> Router env)
-> (Server api' -> Server api)
-> Proxy api'
-> Context ctx
-> Delayed env (Server api')
-> Router env
inRouteServer @(Summary s :> LoggingApiRec config lcontext res) Proxy (Summary s :> LoggingApiRec config lcontext res)
-> Context ctx
-> Delayed
env (Server (Summary s :> LoggingApiRec config lcontext res))
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route Server (LoggingApiRec config lcontext (Summary s :> res))
-> Server (Summary s :> LoggingApiRec config lcontext res)
forall a. a -> a
id
instance HasLoggingServer config lcontext res ctx =>
HasLoggingServer config lcontext (Description d :> res) ctx where
routeWithLog :: Proxy (LoggingApiRec config lcontext (Description d :> res))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (Description d :> res)))
-> Router env
routeWithLog = (Proxy (Description d :> LoggingApiRec config lcontext res)
-> Context ctx
-> Delayed
env (Server (Description d :> LoggingApiRec config lcontext res))
-> Router env)
-> (Server (LoggingApiRec config lcontext (Description d :> res))
-> Server (Description d :> LoggingApiRec config lcontext res))
-> Proxy (LoggingApiRec config lcontext (Description d :> res))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (Description d :> res)))
-> Router env
forall api api' (ctx :: [*]) env.
(Proxy api
-> Context ctx -> Delayed env (Server api) -> Router env)
-> (Server api' -> Server api)
-> Proxy api'
-> Context ctx
-> Delayed env (Server api')
-> Router env
inRouteServer @(Description d :> LoggingApiRec config lcontext res) Proxy (Description d :> LoggingApiRec config lcontext res)
-> Context ctx
-> Delayed
env (Server (Description d :> LoggingApiRec config lcontext res))
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route Server (LoggingApiRec config lcontext (Description d :> res))
-> Server (Description d :> LoggingApiRec config lcontext res)
forall a. a -> a
id
instance ( HasLoggingServer config (ApplyLoggingMod lcontext mod) res ctx
, HasServer res ctx
) =>
HasLoggingServer config lcontext (LoggingMod mod :> res) ctx where
routeWithLog :: Proxy (LoggingApiRec config lcontext (LoggingMod mod :> res))
-> Context ctx
-> Delayed
env
(Server (LoggingApiRec config lcontext (LoggingMod mod :> res)))
-> Router env
routeWithLog = (Proxy (LoggingApiRec config (ApplyLoggingMod lcontext mod) res)
-> Context ctx
-> Delayed
env
(Server (LoggingApiRec config (ApplyLoggingMod lcontext mod) res))
-> Router env)
-> (Server (LoggingApiRec config lcontext (LoggingMod mod :> res))
-> Server
(LoggingApiRec config (ApplyLoggingMod lcontext mod) res))
-> Proxy (LoggingApiRec config lcontext (LoggingMod mod :> res))
-> Context ctx
-> Delayed
env
(Server (LoggingApiRec config lcontext (LoggingMod mod :> res)))
-> Router env
forall api api' (ctx :: [*]) env.
(Proxy api
-> Context ctx -> Delayed env (Server api) -> Router env)
-> (Server api' -> Server api)
-> Proxy api'
-> Context ctx
-> Delayed env (Server api')
-> Router env
inRouteServer @(LoggingApiRec config (ApplyLoggingMod lcontext mod) res) Proxy (LoggingApiRec config (ApplyLoggingMod lcontext mod) res)
-> Context ctx
-> Delayed
env
(Server (LoggingApiRec config (ApplyLoggingMod lcontext mod) res))
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route Server (LoggingApiRec config lcontext (LoggingMod mod :> res))
-> Server (LoggingApiRec config (ApplyLoggingMod lcontext mod) res)
forall a. a -> a
id
newtype RequestId = RequestId Integer
instance Buildable RequestId where
build :: RequestId -> Builder
build (RequestId Integer
i) = Builder
"#" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Integer
i Integer -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
requestsCounter :: TVar Integer
requestsCounter :: TVar Integer
requestsCounter = IO (TVar Integer) -> TVar Integer
forall a. IO a -> a
unsafePerformIO (IO (TVar Integer) -> TVar Integer)
-> IO (TVar Integer) -> TVar Integer
forall a b. (a -> b) -> a -> b
$ Integer -> IO (TVar Integer)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Integer
0
{-# NOINLINE requestsCounter #-}
nextRequestId :: MonadIO m => m RequestId
nextRequestId :: m RequestId
nextRequestId = STM RequestId -> m RequestId
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM RequestId -> m RequestId) -> STM RequestId -> m RequestId
forall a b. (a -> b) -> a -> b
$ do
TVar Integer -> (Integer -> Integer) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Integer
requestsCounter (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1)
Integer -> RequestId
RequestId (Integer -> RequestId) -> STM Integer -> STM RequestId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Integer -> STM Integer
forall a. TVar a -> STM a
readTVar TVar Integer
requestsCounter
applyServantLogging
:: ( Reifies config ServantLogConfig
, Demote (lcontext :: LoggingContext)
, Demote (LcResponsesEnabled lcontext)
, ReflectMethod (method :: k)
)
=> Proxy config
-> Proxy lcontext
-> Proxy method
-> ApiParamsLogInfo
-> If (LcResponsesEnabled lcontext) (a -> Text) ()
-> Handler a
-> Handler a
applyServantLogging :: Proxy config
-> Proxy lcontext
-> Proxy method
-> ApiParamsLogInfo
-> If (LcResponsesEnabled lcontext) (a -> Text) ()
-> Handler a
-> Handler a
applyServantLogging Proxy config
configP (Proxy lcontext
contextP :: Proxy lcontext) Proxy method
methodP ApiParamsLogInfo
paramsInfo If (LcResponsesEnabled lcontext) (a -> Text) ()
showResponse Handler a
action = do
Handler Text
timer <- Handler (Handler Text)
forall (m :: * -> *). MonadIO m => m (m Text)
mkTimer
RequestId
reqId <- Handler RequestId
forall (m :: * -> *). MonadIO m => m RequestId
nextRequestId
RequestId -> Handler Text -> Handler a -> Handler a
forall a a a.
(Buildable a, Buildable a) =>
a -> Handler a -> Handler a -> Handler a
catchErrors RequestId
reqId Handler Text
timer (Handler a -> Handler a) -> Handler a -> Handler a
forall a b. (a -> b) -> a -> b
$ do
RequestId -> Handler ()
reportRequest RequestId
reqId
a
res <- Handler a
action
RequestId -> Handler Text -> a -> Handler ()
reportResponse RequestId
reqId Handler Text
timer a
res
a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
where
method :: Text
method = Method -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (Method -> Text) -> Method -> Text
forall a b. (a -> b) -> a -> b
$ Proxy method -> Method
forall k (a :: k). ReflectMethod a => Proxy a -> Method
reflectMethod Proxy method
methodP :: Text
cmethod :: Text
cmethod =
let c :: Color
c = case Text
method of
Text
"GET" -> Color
Cyan
Text
"POST" -> Color
Yellow
Text
"PUT" -> Color
Green
Text
"DELETE" -> Color
Red
Text
_ -> Color
Magenta
in Style -> Text -> Text
forall a. Pretty a => Style -> a -> a
style Style
Faint (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Color -> Text -> Text
forall a. Pretty a => Color -> a -> a
color Color
c Text
method
mkTimer :: MonadIO m => m (m Text)
mkTimer :: m (m Text)
mkTimer = do
POSIXTime
startTime <- IO POSIXTime -> m POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime
m Text -> m (m Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (m Text -> m (m Text)) -> m Text -> m (m Text)
forall a b. (a -> b) -> a -> b
$ do
POSIXTime
endTime <- IO POSIXTime -> m POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime
Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> m Text) -> (POSIXTime -> Text) -> POSIXTime -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> Text
forall b a. (Show a, IsString b) => a -> b
show (POSIXTime -> m Text) -> POSIXTime -> m Text
forall a b. (a -> b) -> a -> b
$ POSIXTime
endTime POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
- POSIXTime
startTime
logContext :: Demoted LoggingContext
logContext = Proxy lcontext -> Demoted LoggingContext
forall k (ty :: k). Demote ty => Proxy ty -> Demoted k
demote Proxy lcontext
contextP
logEntryContext :: LogContext
logEntryContext = LogContext :: Maybe Natural -> LogContext
LogContext
{ lecRecommendedLevel :: Maybe Natural
lecRecommendedLevel = LogFullContext -> Maybe Natural
lcRecommendedLevel Demoted LoggingContext
LogFullContext
logContext
}
log :: Text -> Handler ()
log :: Text -> Handler ()
log Text
txt = IO () -> Handler ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Handler ()) -> IO () -> Handler ()
forall a b. (a -> b) -> a -> b
$ ServantLogConfig -> LogContext -> Text -> IO ()
clcLog (Proxy config -> ServantLogConfig
forall k (s :: k) a (proxy :: k -> *). Reifies s a => proxy s -> a
reflect Proxy config
configP) LogContext
logEntryContext Text
txt
eParamLogs :: Either Text Text
eParamLogs :: Either Text Text
eParamLogs = case ApiParamsLogInfo
paramsInfo of
ApiParamsLogInfo Bool
_ [Text]
path [Text]
infos -> Text -> Either Text Text
forall a b. b -> Either a b
Right (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$
let pathPart :: Text
pathPart =
Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
gray Text
":>" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
Text -> [Text] -> Text
T.intercalate (Text -> Text
gray Text
"/") ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
path)
infoPart :: [Text]
infoPart = [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
infos [Text] -> (Text -> Text) -> [Text]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Text
info ->
Builder
" " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Text -> Text
gray Text
":>"
Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Text
info Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
in Text -> [Text] -> Text
T.intercalate Text
"\n" (Text
pathPart Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
infoPart)
ApiNoParamsLogInfo Text
why -> Text -> Either Text Text
forall a b. a -> Either a b
Left Text
why
reportRequest :: RequestId -> Handler ()
reportRequest :: RequestId -> Handler ()
reportRequest RequestId
reqId =
Bool -> Handler () -> Handler ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogFullContext -> Bool
lcRequestsEnabled Demoted LoggingContext
LogFullContext
logContext) (Handler () -> Handler ()) -> Handler () -> Handler ()
forall a b. (a -> b) -> a -> b
$
case Either Text Text
eParamLogs of
Left Text
e ->
Text -> Handler ()
log (Text -> Handler ()) -> Text -> Handler ()
forall a b. (a -> b) -> a -> b
$ Builder
"\n" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Color -> Text -> Text
dullColor Color
Red Text
"Unexecuted request due to error"
Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Text
e
Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
Right Text
paramLogs -> do
Text -> Handler ()
log (Text -> Handler ()) -> Text -> Handler ()
forall a b. (a -> b) -> a -> b
$ Builder
"\n" Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Text
cmethod
Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Text -> Text
gray (Text
"Request " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RequestId -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty RequestId
reqId)
Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
"\n" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Text
paramLogs Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
responseTag :: a -> a
responseTag a
reqId = a
"Response " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a -> a
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty a
reqId
reportResponse :: RequestId -> Handler Text -> a -> Handler ()
reportResponse RequestId
reqId Handler Text
timer a
resp =
case Proxy (LcResponsesEnabled lcontext)
-> Either
(Dict (LcResponsesEnabled lcontext ~ 'False))
(Dict (LcResponsesEnabled lcontext ~ 'True))
forall (b :: Bool).
Demote b =>
Proxy b -> Either (Dict (b ~ 'False)) (Dict (b ~ 'True))
tyBoolCase (Proxy (LcResponsesEnabled lcontext)
forall k (t :: k). Proxy t
Proxy @(LcResponsesEnabled lcontext)) of
Left Dict (LcResponsesEnabled lcontext ~ 'False)
_ -> Handler ()
forall (f :: * -> *). Applicative f => f ()
pass
Right Dict (LcResponsesEnabled lcontext ~ 'True)
Dict -> do
Text
durationText <- Handler Text
timer
Text -> Handler ()
log (Text -> Handler ()) -> Text -> Handler ()
forall a b. (a -> b) -> a -> b
$
Builder
"\n " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Text -> Text
gray (RequestId -> Text
forall a a.
(Semigroup a, IsString a, Buildable a, FromBuilder a) =>
a -> a
responseTag RequestId
reqId)
Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Color -> Text -> Text
dullColor Color
Green Text
"OK"
Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Text
durationText
Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Text -> Text
gray Text
">"
Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| If (LcResponsesEnabled lcontext) (a -> Text) ()
a -> Text
showResponse a
resp
Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
catchErrors :: a -> Handler a -> Handler a -> Handler a
catchErrors a
reqId Handler a
st =
(Handler a -> (ServerError -> Handler a) -> Handler a)
-> (ServerError -> Handler a) -> Handler a -> Handler a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Handler a -> (ServerError -> Handler a) -> Handler a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (a -> Handler a -> ServerError -> Handler a
forall a a b.
(Buildable a, Buildable a) =>
a -> Handler a -> ServerError -> Handler b
servantErrHandler a
reqId Handler a
st) (Handler a -> Handler a)
-> (Handler a -> Handler a) -> Handler a -> Handler a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(SomeException -> Handler a) -> Handler a -> Handler a
forall (m :: * -> *) a.
MonadCatch m =>
(SomeException -> m a) -> m a -> m a
handleAny (a -> Handler a -> SomeException -> Handler a
forall e a a b.
(Buildable a, Buildable a, Exception e) =>
a -> Handler a -> e -> Handler b
exceptionsHandler a
reqId Handler a
st)
servantErrHandler :: a -> Handler a -> ServerError -> Handler b
servantErrHandler a
reqId Handler a
timer err :: ServerError
err@ServerError{Int
String
[Header]
ByteString
errHTTPCode :: ServerError -> Int
errReasonPhrase :: ServerError -> String
errBody :: ServerError -> ByteString
errHeaders :: ServerError -> [Header]
errHeaders :: [Header]
errBody :: ByteString
errReasonPhrase :: String
errHTTPCode :: Int
..} = do
a
durationText <- Handler a
timer
let errMsg :: Text
errMsg = Int
errHTTPCode Int -> Builder -> Text
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| String
errReasonPhrase String -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
":"
Text -> Handler ()
log (Text -> Handler ()) -> Text -> Handler ()
forall a b. (a -> b) -> a -> b
$
Builder
"\n " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Text -> Text
gray (a -> Text
forall a a.
(Semigroup a, IsString a, Buildable a, FromBuilder a) =>
a -> a
responseTag a
reqId)
Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| a
durationText
a -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| Color -> Text -> Text
dullColor Color
Red Text
errMsg
Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 @Text ByteString
errBody
Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
ServerError -> Handler b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err
exceptionsHandler :: a -> Handler a -> e -> Handler b
exceptionsHandler a
reqId Handler a
timer e
e = do
a
durationText <- Handler a
timer
Text -> Handler ()
log (Text -> Handler ()) -> Text -> Handler ()
forall a b. (a -> b) -> a -> b
$
Builder
"\n " Builder -> Builder -> Text
forall b. FromBuilder b => Builder -> Builder -> b
+| Color -> Text -> Text
dullColor Color
Red (a -> Text
forall a a.
(Semigroup a, IsString a, Buildable a, FromBuilder a) =>
a -> a
responseTag a
reqId)
Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| e
e
e -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+ Builder
" " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| a
durationText
a -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
e -> Handler b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM e
e
applyLoggingToHandler
:: forall k config lcontext method a.
( Reifies config ServantLogConfig
, Demote lcontext
, BuildableForResponseIfNecessary lcontext a
, Demote lcontext
, ReflectMethod method
)
=> Proxy config -> Proxy (lcontext :: LoggingContext) -> Proxy (method :: k)
-> (ApiParamsLogInfo, Handler a) -> Handler a
applyLoggingToHandler :: Proxy config
-> Proxy lcontext
-> Proxy method
-> (ApiParamsLogInfo, Handler a)
-> Handler a
applyLoggingToHandler Proxy config
configP Proxy lcontext
contextP Proxy method
methodP (ApiParamsLogInfo
paramsInfo, Handler a
handler) = do
let apply :: If (LcResponsesEnabled lcontext) (a -> Text) () -> Handler a
apply If (LcResponsesEnabled lcontext) (a -> Text) ()
format =
Proxy config
-> Proxy lcontext
-> Proxy method
-> ApiParamsLogInfo
-> If (LcResponsesEnabled lcontext) (a -> Text) ()
-> Handler a
-> Handler a
forall k (config :: k) (lcontext :: LoggingContext) k (method :: k)
a.
(Reifies config ServantLogConfig, Demote lcontext,
Demote (LcResponsesEnabled lcontext), ReflectMethod method) =>
Proxy config
-> Proxy lcontext
-> Proxy method
-> ApiParamsLogInfo
-> If (LcResponsesEnabled lcontext) (a -> Text) ()
-> Handler a
-> Handler a
applyServantLogging Proxy config
configP Proxy lcontext
contextP Proxy method
methodP ApiParamsLogInfo
paramsInfo If (LcResponsesEnabled lcontext) (a -> Text) ()
format Handler a
handler
case Proxy (LcResponsesEnabled lcontext)
-> Either
(Dict (LcResponsesEnabled lcontext ~ 'False))
(Dict (LcResponsesEnabled lcontext ~ 'True))
forall (b :: Bool).
Demote b =>
Proxy b -> Either (Dict (b ~ 'False)) (Dict (b ~ 'True))
tyBoolCase (Proxy (LcResponsesEnabled lcontext)
-> Either
(Dict (LcResponsesEnabled lcontext ~ 'False))
(Dict (LcResponsesEnabled lcontext ~ 'True)))
-> Proxy (LcResponsesEnabled lcontext)
-> Either
(Dict (LcResponsesEnabled lcontext ~ 'False))
(Dict (LcResponsesEnabled lcontext ~ 'True))
forall a b. (a -> b) -> a -> b
$ Proxy (LcResponsesEnabled lcontext)
forall k (t :: k). Proxy t
Proxy @(LcResponsesEnabled lcontext) of
Right Dict (LcResponsesEnabled lcontext ~ 'True)
Dict -> If (LcResponsesEnabled lcontext) (a -> Text) () -> Handler a
apply (ForResponseLog a -> Text
forall a b. (Buildable a, FromBuilder b) => a -> b
pretty (ForResponseLog a -> Text) -> (a -> ForResponseLog a) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ForResponseLog a
forall a. a -> ForResponseLog a
ForResponseLog)
Left Dict (LcResponsesEnabled lcontext ~ 'False)
Dict -> If (LcResponsesEnabled lcontext) (a -> Text) () -> Handler a
apply ()
skipLogging :: (ApiParamsLogInfo, action) -> action
skipLogging :: (ApiParamsLogInfo, action) -> action
skipLogging = (ApiParamsLogInfo, action) -> action
forall a b. (a, b) -> b
snd
instance ( HasServer (Verb mt st ct a) ctx
, Reifies config ServantLogConfig
, Demote lcontext
, ReflectMethod mt
, BuildableForResponseIfNecessary lcontext a
) =>
HasLoggingServer config lcontext (Verb (mt :: k) (st :: Nat) (ct :: [Type]) a) ctx where
routeWithLog :: Proxy (LoggingApiRec config lcontext (Verb mt st ct a))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (Verb mt st ct a)))
-> Router env
routeWithLog =
(Proxy (Verb mt st ct a)
-> Context ctx
-> Delayed env (Server (Verb mt st ct a))
-> Router env)
-> (Server (LoggingApiRec config lcontext (Verb mt st ct a))
-> Server (Verb mt st ct a))
-> Proxy (LoggingApiRec config lcontext (Verb mt st ct a))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (Verb mt st ct a)))
-> Router env
forall api api' (ctx :: [*]) env.
(Proxy api
-> Context ctx -> Delayed env (Server api) -> Router env)
-> (Server api' -> Server api)
-> Proxy api'
-> Context ctx
-> Delayed env (Server api')
-> Router env
inRouteServer @(Verb mt st ct a) Proxy (Verb mt st ct a)
-> Context ctx
-> Delayed env (Server (Verb mt st ct a))
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route ((Server (LoggingApiRec config lcontext (Verb mt st ct a))
-> Server (Verb mt st ct a))
-> Proxy (LoggingApiRec config lcontext (Verb mt st ct a))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (Verb mt st ct a)))
-> Router env)
-> (Server (LoggingApiRec config lcontext (Verb mt st ct a))
-> Server (Verb mt st ct a))
-> Proxy (LoggingApiRec config lcontext (Verb mt st ct a))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (Verb mt st ct a)))
-> Router env
forall a b. (a -> b) -> a -> b
$
Proxy config
-> Proxy lcontext
-> Proxy mt
-> (ApiParamsLogInfo, Handler a)
-> Handler a
forall k k (config :: k) (lcontext :: LoggingContext) (method :: k)
a.
(Reifies config ServantLogConfig, Demote lcontext,
BuildableForResponseIfNecessary lcontext a, Demote lcontext,
ReflectMethod method) =>
Proxy config
-> Proxy lcontext
-> Proxy method
-> (ApiParamsLogInfo, Handler a)
-> Handler a
applyLoggingToHandler (Proxy config
forall k (t :: k). Proxy t
Proxy @config) (Proxy lcontext
forall k (t :: k). Proxy t
Proxy @lcontext) (Proxy mt
forall k (t :: k). Proxy t
Proxy @mt)
instance ( HasServer (NoContentVerb mt) ctx
, Reifies config ServantLogConfig
, Demote lcontext
, ReflectMethod mt
, BuildableForResponseIfNecessary lcontext NoContent
) =>
HasLoggingServer config lcontext (NoContentVerb (mt :: k)) ctx where
routeWithLog :: Proxy (LoggingApiRec config lcontext (NoContentVerb mt))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (NoContentVerb mt)))
-> Router env
routeWithLog =
(Proxy (NoContentVerb mt)
-> Context ctx
-> Delayed env (Server (NoContentVerb mt))
-> Router env)
-> (Server (LoggingApiRec config lcontext (NoContentVerb mt))
-> Server (NoContentVerb mt))
-> Proxy (LoggingApiRec config lcontext (NoContentVerb mt))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (NoContentVerb mt)))
-> Router env
forall api api' (ctx :: [*]) env.
(Proxy api
-> Context ctx -> Delayed env (Server api) -> Router env)
-> (Server api' -> Server api)
-> Proxy api'
-> Context ctx
-> Delayed env (Server api')
-> Router env
inRouteServer @(NoContentVerb mt) Proxy (NoContentVerb mt)
-> Context ctx
-> Delayed env (Server (NoContentVerb mt))
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route ((Server (LoggingApiRec config lcontext (NoContentVerb mt))
-> Server (NoContentVerb mt))
-> Proxy (LoggingApiRec config lcontext (NoContentVerb mt))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (NoContentVerb mt)))
-> Router env)
-> (Server (LoggingApiRec config lcontext (NoContentVerb mt))
-> Server (NoContentVerb mt))
-> Proxy (LoggingApiRec config lcontext (NoContentVerb mt))
-> Context ctx
-> Delayed
env (Server (LoggingApiRec config lcontext (NoContentVerb mt)))
-> Router env
forall a b. (a -> b) -> a -> b
$
Proxy config
-> Proxy lcontext
-> Proxy mt
-> (ApiParamsLogInfo, Handler NoContent)
-> Handler NoContent
forall k k (config :: k) (lcontext :: LoggingContext) (method :: k)
a.
(Reifies config ServantLogConfig, Demote lcontext,
BuildableForResponseIfNecessary lcontext a, Demote lcontext,
ReflectMethod method) =>
Proxy config
-> Proxy lcontext
-> Proxy method
-> (ApiParamsLogInfo, Handler a)
-> Handler a
applyLoggingToHandler (Proxy config
forall k (t :: k). Proxy t
Proxy @config) (Proxy lcontext
forall k (t :: k). Proxy t
Proxy @lcontext) (Proxy mt
forall k (t :: k). Proxy t
Proxy @mt)
instance HasLoggingServer config lcontext Raw ctx where
routeWithLog :: Proxy (LoggingApiRec config lcontext Raw)
-> Context ctx
-> Delayed env (Server (LoggingApiRec config lcontext Raw))
-> Router env
routeWithLog = (Proxy Raw
-> Context ctx -> Delayed env (Server Raw) -> Router env)
-> (Server (LoggingApiRec config lcontext Raw) -> Server Raw)
-> Proxy (LoggingApiRec config lcontext Raw)
-> Context ctx
-> Delayed env (Server (LoggingApiRec config lcontext Raw))
-> Router env
forall api api' (ctx :: [*]) env.
(Proxy api
-> Context ctx -> Delayed env (Server api) -> Router env)
-> (Server api' -> Server api)
-> Proxy api'
-> Context ctx
-> Delayed env (Server api')
-> Router env
inRouteServer @Raw Proxy Raw -> Context ctx -> Delayed env (Server Raw) -> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route Server (LoggingApiRec config lcontext Raw) -> Server Raw
forall action. (ApiParamsLogInfo, action) -> action
skipLogging
instance Buildable (ForResponseLog NoContent) where
build :: ForResponseLog NoContent -> Builder
build ForResponseLog NoContent
_ = Builder
"<no response>"
instance Buildable (ForResponseLog ()) where
build :: ForResponseLog () -> Builder
build ForResponseLog ()
_ = Builder
"<no response>"
instance Buildable (ForResponseLog Integer) where
build :: ForResponseLog Integer -> Builder
build = ForResponseLog Integer -> Builder
forall a. Buildable a => ForResponseLog a -> Builder
buildForResponse
instance Buildable (ForResponseLog Swagger) where
build :: ForResponseLog Swagger -> Builder
build ForResponseLog Swagger
_ = Builder
"Swagger specification"
instance Buildable (ForResponseLog (SwaggerUiHtml dir api)) where
build :: ForResponseLog (SwaggerUiHtml dir api) -> Builder
build ForResponseLog (SwaggerUiHtml dir api)
_ = Builder
"Accessed documentation UI"
instance HasServer api ctx =>
HasServer (LoggingMod mod :> api) ctx where
type ServerT (LoggingMod mod :> api) m = ServerT api m
route :: Proxy (LoggingMod mod :> api)
-> Context ctx
-> Delayed env (Server (LoggingMod mod :> api))
-> Router env
route = (Proxy api
-> Context ctx -> Delayed env (Server api) -> Router env)
-> (Server (LoggingMod mod :> api) -> Server api)
-> Proxy (LoggingMod mod :> api)
-> Context ctx
-> Delayed env (Server (LoggingMod mod :> api))
-> Router env
forall api api' (ctx :: [*]) env.
(Proxy api
-> Context ctx -> Delayed env (Server api) -> Router env)
-> (Server api' -> Server api)
-> Proxy api'
-> Context ctx
-> Delayed env (Server api')
-> Router env
inRouteServer @api Proxy api -> Context ctx -> Delayed env (Server api) -> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route Server (LoggingMod mod :> api) -> Server api
forall a. a -> a
id
hoistServerWithContext :: Proxy (LoggingMod mod :> api)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (LoggingMod mod :> api) m
-> ServerT (LoggingMod mod :> api) n
hoistServerWithContext Proxy (LoggingMod mod :> api)
_ = Proxy api
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
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
forall k (t :: k). Proxy t
Proxy @api)
instance HasClient m api =>
HasClient m (LoggingMod mod :> api) where
type Client m (LoggingMod mod :> api) = Client m api
clientWithRoute :: Proxy m
-> Proxy (LoggingMod mod :> api)
-> Request
-> Client m (LoggingMod mod :> api)
clientWithRoute Proxy m
mp Proxy (LoggingMod mod :> api)
_ = Proxy m -> Proxy api -> Request -> Client m api
forall (m :: * -> *) api.
HasClient m api =>
Proxy m -> Proxy api -> Request -> Client m api
clientWithRoute Proxy m
mp (Proxy api
forall k (t :: k). Proxy t
Proxy @api)
hoistClientMonad :: Proxy m
-> Proxy (LoggingMod mod :> api)
-> (forall x. mon x -> mon' x)
-> Client mon (LoggingMod mod :> api)
-> Client mon' (LoggingMod mod :> api)
hoistClientMonad Proxy m
mp Proxy (LoggingMod mod :> api)
_ = Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
forall (m :: * -> *) api (mon :: * -> *) (mon' :: * -> *).
HasClient m api =>
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
hoistClientMonad Proxy m
mp (Proxy api
forall k (t :: k). Proxy t
Proxy @api)
instance HasSwagger api =>
HasSwagger (LoggingMod mod :> api) where
toSwagger :: Proxy (LoggingMod mod :> api) -> Swagger
toSwagger Proxy (LoggingMod mod :> api)
_ = Proxy api -> Swagger
forall k (api :: k). HasSwagger api => Proxy api -> Swagger
toSwagger (Proxy api
forall k (t :: k). Proxy t
Proxy @api)
serverWithLogging
:: forall api a.
ServantLogConfig
-> Proxy api
-> (forall (config :: Type). Reifies config ServantLogConfig =>
Proxy (LoggingApi config api) -> a)
-> a
serverWithLogging :: ServantLogConfig
-> Proxy api
-> (forall config.
Reifies config ServantLogConfig =>
Proxy (LoggingApi config api) -> a)
-> a
serverWithLogging ServantLogConfig
config Proxy api
_ forall config.
Reifies config ServantLogConfig =>
Proxy (LoggingApi config api) -> a
f =
ServantLogConfig
-> (forall s. Reifies s ServantLogConfig => Proxy s -> a) -> a
forall a r. a -> (forall s. Reifies s a => Proxy s -> r) -> r
reify ServantLogConfig
config ((forall s. Reifies s ServantLogConfig => Proxy s -> a) -> a)
-> (forall s. Reifies s ServantLogConfig => Proxy s -> a) -> a
forall a b. (a -> b) -> a -> b
$ \(Proxy s
Proxy :: Proxy config) -> Proxy (LoggingApi s api) -> a
forall config.
Reifies config ServantLogConfig =>
Proxy (LoggingApi config api) -> a
f (Proxy (LoggingApi s api)
forall k (t :: k). Proxy t
Proxy @(LoggingApi config api))