{-# LANGUAGE PolyKinds #-}

-- | Allows to enable logging of requests and responses.
module Servant.Util.Combinators.Logging
    ( -- * Automatic requests logging
      LoggingApi
    , LoggingApiRec
    , HasLoggingServer (..)
    , ServantLogConfig (..)
    , ForResponseLog (..)
    , buildListForResponse
    , buildForResponse
    , ApiHasArgClass (..)
    , ApiCanLogArg (..)
    , addParamLogInfo
    , setInPrefix
    , serverWithLogging
    ) where

import Universum

import Control.Monad.Error.Class (catchError, throwError)
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.Server (Handler (..), HasServer (..), Server, ServerError (..))
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

-- | Enables logging for server which serves given api.
--
-- `config` is a type at which you have to specify 'ServantLogConfig' via
-- reflection. This way was chosen because the least thing we need in
-- config is 'LoggerName', and we want to have '<>' on 'LoggerName's thus
-- 'KnownSymbol' is not enough.
--
-- This logging will report
--
-- * Request parameters, including request bodies
-- * If execution failed with error, it will be displayed
-- * Details like request method and endpoint execution time
--
-- If user makes request which is not defined it won't be logged. However,
-- I don't find it a great problem, it may impede only in development or on
-- getting acknowledged with api.
data LoggingApi config api

-- | Helper to traverse servant api and apply logging.
data LoggingApiRec config api

newtype ServantLogConfig = ServantLogConfig
    { ServantLogConfig -> Text -> IO ()
clcLog :: 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

-- | Used to incrementally collect info about passed parameters.
data ApiParamsLogInfo
      -- | Parameters gathered at current stage.
      -- The first field tells whether have we met '(:<|>)',
      -- the second is path prefix itself,
      -- the third field is the remaining part.
    = ApiParamsLogInfo Bool [Text] [Text]
      -- | Parameters collection failed with reason
      --   (e.g. decoding error)
    | 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

-- | When it comes to logging responses, returned data may be very large.
-- Log space is valuable (already in testnet we got truncated logs),
-- so we have to care about printing only whose data which may be useful.
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 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 api)
 -> Context ctx
 -> Delayed env (Server (LoggingApiRec config api))
 -> Router env)
-> (Server (LoggingApi config api)
    -> Server (LoggingApiRec config 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 api) Proxy (LoggingApiRec config api)
-> Context ctx
-> Delayed env (Server (LoggingApiRec config 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)

-- | Version of 'HasServer' which is assumed to perform logging.
-- It's helpful because 'ServerT (LoggingApi ...)' is already defined for us
-- in actual 'HasServer' instance once and forever.
class HasServer api ctx => HasLoggingServer config api ctx where
    routeWithLog
        :: Proxy (LoggingApiRec config api)
        -> SI.Context ctx
        -> SI.Delayed env (Server (LoggingApiRec config api))
        -> SI.Router env

instance HasLoggingServer config api ctx =>
         HasServer (LoggingApiRec config api) ctx where
    type ServerT (LoggingApiRec config api) m =
         (ApiParamsLogInfo, ServerT api m)

    route :: Proxy (LoggingApiRec config api)
-> Context ctx
-> Delayed env (Server (LoggingApiRec config api))
-> Router env
route = Proxy (LoggingApiRec config api)
-> Context ctx
-> Delayed env (Server (LoggingApiRec config api))
-> Router env
forall k k (config :: k) (api :: k) (ctx :: [*]) env.
HasLoggingServer config api ctx =>
Proxy (LoggingApiRec config api)
-> Context ctx
-> Delayed env (Server (LoggingApiRec config api))
-> Router env
routeWithLog

    hoistServerWithContext :: Proxy (LoggingApiRec config api)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (LoggingApiRec config api) m
-> ServerT (LoggingApiRec config api) n
hoistServerWithContext Proxy (LoggingApiRec config api)
_ Proxy ctx
pc forall x. m x -> n x
nt ServerT (LoggingApiRec config 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 api) m
s

instance ( HasLoggingServer config api1 ctx
         , HasLoggingServer config api2 ctx
         ) =>
         HasLoggingServer config (api1 :<|> api2) ctx where
    routeWithLog :: Proxy (LoggingApiRec config (api1 :<|> api2))
-> Context ctx
-> Delayed env (Server (LoggingApiRec config (api1 :<|> api2)))
-> Router env
routeWithLog =
        (Proxy (LoggingApiRec config api1 :<|> LoggingApiRec config api2)
 -> Context ctx
 -> Delayed
      env
      (Server (LoggingApiRec config api1 :<|> LoggingApiRec config api2))
 -> Router env)
-> (Server (LoggingApiRec config (api1 :<|> api2))
    -> Server
         (LoggingApiRec config api1 :<|> LoggingApiRec config api2))
-> Proxy (LoggingApiRec config (api1 :<|> api2))
-> Context ctx
-> Delayed env (Server (LoggingApiRec config (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 api1 :<|> LoggingApiRec config api2)
            Proxy (LoggingApiRec config api1 :<|> LoggingApiRec config api2)
-> Context ctx
-> Delayed
     env
     (Server (LoggingApiRec config api1 :<|> LoggingApiRec config 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 (api1 :<|> api2))
  -> Server
       (LoggingApiRec config api1 :<|> LoggingApiRec config api2))
 -> Proxy (LoggingApiRec config (api1 :<|> api2))
 -> Context ctx
 -> Delayed env (Server (LoggingApiRec config (api1 :<|> api2)))
 -> Router env)
-> (Server (LoggingApiRec config (api1 :<|> api2))
    -> Server
         (LoggingApiRec config api1 :<|> LoggingApiRec config api2))
-> Proxy (LoggingApiRec config (api1 :<|> api2))
-> Context ctx
-> Delayed env (Server (LoggingApiRec config (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 res ctx
         ) =>
         HasLoggingServer config (path :> res) ctx where
    routeWithLog :: Proxy (LoggingApiRec config (path :> res))
-> Context ctx
-> Delayed env (Server (LoggingApiRec config (path :> res)))
-> Router env
routeWithLog =
        (Proxy (path :> LoggingApiRec config res)
 -> Context ctx
 -> Delayed env (Server (path :> LoggingApiRec config res))
 -> Router env)
-> (Server (LoggingApiRec config (path :> res))
    -> Server (path :> LoggingApiRec config res))
-> Proxy (LoggingApiRec config (path :> res))
-> Context ctx
-> Delayed env (Server (LoggingApiRec config (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 res) Proxy (path :> LoggingApiRec config res)
-> Context ctx
-> Delayed env (Server (path :> LoggingApiRec config 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 (path :> res))
  -> Server (path :> LoggingApiRec config res))
 -> Proxy (LoggingApiRec config (path :> res))
 -> Context ctx
 -> Delayed env (Server (LoggingApiRec config (path :> res)))
 -> Router env)
-> (Server (LoggingApiRec config (path :> res))
    -> Server (path :> LoggingApiRec config res))
-> Proxy (LoggingApiRec config (path :> res))
-> Context ctx
-> Delayed env (Server (LoggingApiRec config (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

-- | Describes a way to log a single parameter.
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 api subApi res ctx env.
       ( api ~ (subApi :> res)
       , HasServer (subApi :> LoggingApiRec config res) ctx
       , ApiHasArg subApi res
       , ApiHasArg subApi (LoggingApiRec config res)
       , ApiCanLogArg subApi
       , Buildable (ApiArgToLog subApi)
       )
    => Proxy (LoggingApiRec config api)
    -> SI.Context ctx
    -> SI.Delayed env (Server (LoggingApiRec config api))
    -> SI.Router env
paramRouteWithLog :: Proxy (LoggingApiRec config api)
-> Context ctx
-> Delayed env (Server (LoggingApiRec config api))
-> Router env
paramRouteWithLog =
    (Proxy (subApi :> LoggingApiRec config res)
 -> Context ctx
 -> Delayed env (Server (subApi :> LoggingApiRec config res))
 -> Router env)
-> (Server (LoggingApiRec config api)
    -> Server (subApi :> LoggingApiRec config res))
-> Proxy (LoggingApiRec config api)
-> Context ctx
-> Delayed env (Server (LoggingApiRec 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 @(subApi :> LoggingApiRec config res) Proxy (subApi :> LoggingApiRec config res)
-> Context ctx
-> Delayed env (Server (subApi :> LoggingApiRec config 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 api)
  -> Server (subApi :> LoggingApiRec config res))
 -> Proxy (LoggingApiRec config api)
 -> Context ctx
 -> Delayed env (Server (LoggingApiRec config api))
 -> Router env)
-> (Server (LoggingApiRec config api)
    -> Server (subApi :> LoggingApiRec config res))
-> Proxy (LoggingApiRec config api)
-> Context ctx
-> Delayed env (Server (LoggingApiRec config 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 res) ctx
         , ApiHasArg subApi res
         , ApiHasArg subApi (LoggingApiRec config res)
         , ApiCanLogArg subApi
         , Buildable (ApiArgToLog subApi)
         , subApi ~ apiType (a :: Type)
         ) =>
         HasLoggingServer config (apiType a :> res) ctx where
    routeWithLog :: Proxy (LoggingApiRec config (apiType a :> res))
-> Context ctx
-> Delayed env (Server (LoggingApiRec config (apiType a :> res)))
-> Router env
routeWithLog = Proxy (LoggingApiRec config (apiType a :> res))
-> Context ctx
-> Delayed env (Server (LoggingApiRec config (apiType a :> res)))
-> Router env
forall k (config :: k) api subApi res (ctx :: [*]) env.
(api ~ (subApi :> res),
 HasServer (subApi :> LoggingApiRec config res) ctx,
 ApiHasArg subApi res, ApiHasArg subApi (LoggingApiRec config res),
 ApiCanLogArg subApi, Buildable (ApiArgToLog subApi)) =>
Proxy (LoggingApiRec config api)
-> Context ctx
-> Delayed env (Server (LoggingApiRec config api))
-> Router env
paramRouteWithLog

instance ( HasLoggingServer config res ctx
         , KnownSymbol s
         ) =>
         HasLoggingServer config (QueryFlag s :> res) ctx where
    routeWithLog :: Proxy (LoggingApiRec config (QueryFlag s :> res))
-> Context ctx
-> Delayed env (Server (LoggingApiRec config (QueryFlag s :> res)))
-> Router env
routeWithLog = Proxy (LoggingApiRec config (QueryFlag s :> res))
-> Context ctx
-> Delayed env (Server (LoggingApiRec config (QueryFlag s :> res)))
-> Router env
forall k (config :: k) api subApi res (ctx :: [*]) env.
(api ~ (subApi :> res),
 HasServer (subApi :> LoggingApiRec config res) ctx,
 ApiHasArg subApi res, ApiHasArg subApi (LoggingApiRec config res),
 ApiCanLogArg subApi, Buildable (ApiArgToLog subApi)) =>
Proxy (LoggingApiRec config api)
-> Context ctx
-> Delayed env (Server (LoggingApiRec config api))
-> Router env
paramRouteWithLog

instance HasLoggingServer config res ctx =>
         HasLoggingServer config (Summary s :> res) ctx where
    routeWithLog :: Proxy (LoggingApiRec config (Summary s :> res))
-> Context ctx
-> Delayed env (Server (LoggingApiRec config (Summary s :> res)))
-> Router env
routeWithLog = (Proxy (Summary s :> LoggingApiRec config res)
 -> Context ctx
 -> Delayed env (Server (Summary s :> LoggingApiRec config res))
 -> Router env)
-> (Server (LoggingApiRec config (Summary s :> res))
    -> Server (Summary s :> LoggingApiRec config res))
-> Proxy (LoggingApiRec config (Summary s :> res))
-> Context ctx
-> Delayed env (Server (LoggingApiRec config (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 res) Proxy (Summary s :> LoggingApiRec config res)
-> Context ctx
-> Delayed env (Server (Summary s :> LoggingApiRec config 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 (Summary s :> res))
-> Server (Summary s :> LoggingApiRec config res)
forall a. a -> a
id

instance HasLoggingServer config res ctx =>
         HasLoggingServer config (Description d :> res) ctx where
    routeWithLog :: Proxy (LoggingApiRec config (Description d :> res))
-> Context ctx
-> Delayed
     env (Server (LoggingApiRec config (Description d :> res)))
-> Router env
routeWithLog = (Proxy (Description d :> LoggingApiRec config res)
 -> Context ctx
 -> Delayed env (Server (Description d :> LoggingApiRec config res))
 -> Router env)
-> (Server (LoggingApiRec config (Description d :> res))
    -> Server (Description d :> LoggingApiRec config res))
-> Proxy (LoggingApiRec config (Description d :> res))
-> Context ctx
-> Delayed
     env (Server (LoggingApiRec config (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 res) Proxy (Description d :> LoggingApiRec config res)
-> Context ctx
-> Delayed env (Server (Description d :> LoggingApiRec config 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 (Description d :> res))
-> Server (Description d :> LoggingApiRec config res)
forall a. a -> a
id


-- | Unique identifier for request-response pair.
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
""

-- | We want all servant servers to have non-overlapping ids,
-- so using singleton counter here.
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

-- | Modify an action so that it performs all the required logging.
applyServantLogging
    :: ( Reifies config ServantLogConfig
       , ReflectMethod (method :: k)
       )
    => Proxy config
    -> Proxy method
    -> ApiParamsLogInfo
    -> (a -> Text)
    -> Handler a
    -> Handler a
applyServantLogging :: Proxy config
-> Proxy method
-> ApiParamsLogInfo
-> (a -> Text)
-> Handler a
-> Handler a
applyServantLogging Proxy config
configP Proxy method
methodP ApiParamsLogInfo
paramsInfo 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
    log :: Text -> Handler ()
    log :: Text -> Handler ()
log = IO () -> Handler ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Handler ())
-> (ServantLogConfig -> Text -> IO ())
-> ServantLogConfig
-> Text
-> Handler ()
forall a b c. SuperComposition a b c => a -> b -> c
... ServantLogConfig -> Text -> IO ()
clcLog (ServantLogConfig -> Text -> Handler ())
-> ServantLogConfig -> Text -> Handler ()
forall a b. (a -> b) -> a -> b
$ Proxy config -> ServantLogConfig
forall k (s :: k) a (proxy :: k -> *). Reifies s a => proxy s -> a
reflect Proxy config
configP
    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 =
        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 = 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
+| 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 method a.
       ( Buildable (ForResponseLog a)
       , Reifies config ServantLogConfig
       , ReflectMethod method
       )
    => Proxy config -> Proxy (method :: k) -> (ApiParamsLogInfo, Handler a) -> Handler a
applyLoggingToHandler :: Proxy config
-> Proxy method -> (ApiParamsLogInfo, Handler a) -> Handler a
applyLoggingToHandler Proxy config
configP Proxy method
methodP (ApiParamsLogInfo
paramsInfo, Handler a
handler) = do
    Proxy config
-> Proxy method
-> ApiParamsLogInfo
-> (a -> Text)
-> Handler a
-> Handler a
forall k (config :: k) k (method :: k) a.
(Reifies config ServantLogConfig, ReflectMethod method) =>
Proxy config
-> Proxy method
-> ApiParamsLogInfo
-> (a -> Text)
-> Handler a
-> Handler a
applyServantLogging Proxy config
configP Proxy method
methodP ApiParamsLogInfo
paramsInfo (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) Handler a
handler

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
         , ReflectMethod mt
         , Buildable (ForResponseLog a)
         ) =>
         HasLoggingServer config (Verb (mt :: k) (st :: Nat) (ct :: [Type]) a) ctx where
    routeWithLog :: Proxy (LoggingApiRec config (Verb mt st ct a))
-> Context ctx
-> Delayed env (Server (LoggingApiRec config (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 (Verb mt st ct a))
    -> Server (Verb mt st ct a))
-> Proxy (LoggingApiRec config (Verb mt st ct a))
-> Context ctx
-> Delayed env (Server (LoggingApiRec config (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 (Verb mt st ct a))
  -> Server (Verb mt st ct a))
 -> Proxy (LoggingApiRec config (Verb mt st ct a))
 -> Context ctx
 -> Delayed env (Server (LoggingApiRec config (Verb mt st ct a)))
 -> Router env)
-> (Server (LoggingApiRec config (Verb mt st ct a))
    -> Server (Verb mt st ct a))
-> Proxy (LoggingApiRec config (Verb mt st ct a))
-> Context ctx
-> Delayed env (Server (LoggingApiRec config (Verb mt st ct a)))
-> Router env
forall a b. (a -> b) -> a -> b
$
        Proxy config
-> Proxy mt -> (ApiParamsLogInfo, Handler a) -> Handler a
forall k k (config :: k) (method :: k) a.
(Buildable (ForResponseLog a), Reifies config ServantLogConfig,
 ReflectMethod method) =>
Proxy config
-> Proxy method -> (ApiParamsLogInfo, Handler a) -> Handler a
applyLoggingToHandler (Proxy config
forall k (t :: k). Proxy t
Proxy @config) (Proxy mt
forall k (t :: k). Proxy t
Proxy @mt)

instance ( HasServer (NoContentVerb mt) ctx
         , Reifies config ServantLogConfig
         , ReflectMethod mt
         ) =>
         HasLoggingServer config (NoContentVerb (mt :: k)) ctx where
    routeWithLog :: Proxy (LoggingApiRec config (NoContentVerb mt))
-> Context ctx
-> Delayed env (Server (LoggingApiRec config (NoContentVerb mt)))
-> Router env
routeWithLog =
        (Proxy (NoContentVerb mt)
 -> Context ctx
 -> Delayed env (Server (NoContentVerb mt))
 -> Router env)
-> (Server (LoggingApiRec config (NoContentVerb mt))
    -> Server (NoContentVerb mt))
-> Proxy (LoggingApiRec config (NoContentVerb mt))
-> Context ctx
-> Delayed env (Server (LoggingApiRec config (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 (NoContentVerb mt))
  -> Server (NoContentVerb mt))
 -> Proxy (LoggingApiRec config (NoContentVerb mt))
 -> Context ctx
 -> Delayed env (Server (LoggingApiRec config (NoContentVerb mt)))
 -> Router env)
-> (Server (LoggingApiRec config (NoContentVerb mt))
    -> Server (NoContentVerb mt))
-> Proxy (LoggingApiRec config (NoContentVerb mt))
-> Context ctx
-> Delayed env (Server (LoggingApiRec config (NoContentVerb mt)))
-> Router env
forall a b. (a -> b) -> a -> b
$
        Proxy config
-> Proxy mt
-> (ApiParamsLogInfo, Handler NoContent)
-> Handler NoContent
forall k k (config :: k) (method :: k) a.
(Buildable (ForResponseLog a), Reifies config ServantLogConfig,
 ReflectMethod method) =>
Proxy config
-> Proxy method -> (ApiParamsLogInfo, Handler a) -> Handler a
applyLoggingToHandler (Proxy config
forall k (t :: k). Proxy t
Proxy @config) (Proxy mt
forall k (t :: k). Proxy t
Proxy @mt)

instance HasLoggingServer config Raw ctx where
    routeWithLog :: Proxy (LoggingApiRec config Raw)
-> Context ctx
-> Delayed env (Server (LoggingApiRec config Raw))
-> Router env
routeWithLog = (Proxy Raw
 -> Context ctx -> Delayed env (Server Raw) -> Router env)
-> (Server (LoggingApiRec config Raw) -> Server Raw)
-> Proxy (LoggingApiRec config Raw)
-> Context ctx
-> Delayed env (Server (LoggingApiRec config 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 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"

-- | Apply logging to the given server.
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))