module Network.ABCI.Server.Middleware.Logger
(
mkLogger
, mkLoggerM
) where
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Class (lift)
import qualified Data.Aeson as A
import Data.ByteArray.HexString (HexString)
import Data.String (fromString)
import Katip
import Network.ABCI.Server.App (App (..), MessageType, Middleware,
Request (..), Response (..),
demoteRequestType, hashRequest,
msgTypeKey, transformApp)
newtype Loggable a = Loggable a
instance ToObject (Loggable (Request (t :: MessageType))) where
toObject (Loggable v) = case A.toJSON v of
A.Object o -> o
_ -> error "Contract violation: `toJSON` of any `Request t` must result with json object"
instance LogItem (Loggable (Request (t :: MessageType))) where
payloadKeys V3 _ = AllKeys
payloadKeys _ _ = SomeKeys ["type"]
instance ToObject (Loggable (Response (t :: MessageType))) where
toObject (Loggable v) = case A.toJSON v of
A.Object o -> o
_ -> error "Contract violation: `toJSON` of any `Response t` must result with json object"
instance LogItem (Loggable (Response (t :: MessageType))) where
payloadKeys V3 _ = AllKeys
payloadKeys _ _ = SomeKeys ["type"]
mkLogger
:: MonadIO m
=> LogEnv
-> Namespace
-> Middleware m
mkLogger le ns =
transformApp (runKatipContextT le () ns) . mkLoggerM . transformApp lift
mkLoggerM
:: KatipContext m
=> Middleware m
mkLoggerM (App app) = App $ \ req -> do
let globalContext = GlobalMessageContext
{ messageHash = hashRequest req
, messageType = demoteRequestType req
}
katipAddContext globalContext $ do
katipAddNamespace (fromString "server") $
logRequest req
resp <- katipAddNamespace (fromString "application") $
app req
katipAddNamespace (fromString "server") $
logResponse resp
return resp
data GlobalMessageContext = GlobalMessageContext
{ messageHash :: HexString
, messageType :: MessageType
}
instance A.ToJSON GlobalMessageContext where
toJSON GlobalMessageContext {..} =
A.object [ "message_type" A..= msgTypeKey messageType
, "message_hash" A..= messageHash
]
instance ToObject GlobalMessageContext
instance LogItem GlobalMessageContext where
payloadKeys _ _ = AllKeys
logRequest
:: KatipContext m
=> Request t
-> m ()
logRequest req = katipAddContext (Loggable req) $
logFM logLevel "Request Received"
where
logLevel = case req of
RequestFlush _ -> DebugS
RequestEcho _ -> DebugS
_ -> InfoS
logResponse
:: KatipContext m
=> Response t
-> m ()
logResponse resp = katipAddContext (Loggable resp) $
logFM logLevel "Response Sent"
where
logLevel = case resp of
ResponseFlush _ -> DebugS
ResponseEcho _ -> DebugS
_ -> InfoS