module Polysemy.Http.Log where
import Colog.Core (LogAction(LogAction), Severity, cmapM)
import qualified Colog.Core as Severity (Severity(Error, Info, Debug, Warning))
import qualified Colog.Polysemy as Colog (Log, log)
import Colog.Polysemy.Effect (runLogAction)
import qualified Data.ByteString.Char8 as BS8
import GHC.Stack (SrcLoc(SrcLoc), popCallStack, srcLocModule, srcLocStartLine)
import System.Console.ANSI (Color (..), ColorIntensity (Vivid), ConsoleLayer (Foreground), SGR (..), setSGRCode)
import Polysemy.Http.Data.Log (Log(..))
data Message =
Message {
Message -> Severity
msgSeverity :: !Severity,
Message -> CallStack
msgStack :: !CallStack,
Message -> Text
msgText :: !Text
}
showSeverity :: Severity -> Text
showSeverity :: Severity -> Text
showSeverity = \case
Severity.Debug -> Color -> Text -> Text
color Color
Green "[Debug] "
Severity.Info -> Color -> Text -> Text
color Color
Blue "[Info] "
Severity.Warning -> Color -> Text -> Text
color Color
Yellow "[Warning] "
Severity.Error -> Color -> Text -> Text
color Color
Red "[Error] "
where
color :: Color -> Text -> Text
color :: Color -> Text -> Text
color c :: Color
c txt :: Text
txt =
String -> Text
forall a. ToText a => a -> Text
toText ([SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
c]) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
Text
txt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
String -> Text
forall a. ToText a => a -> Text
toText ([SGR] -> String
setSGRCode [SGR
Reset])
showSourceLoc :: CallStack -> Text
showSourceLoc :: CallStack -> Text
showSourceLoc cs :: CallStack
cs =
Text -> Text
forall a. (Semigroup a, IsString a) => a -> a
square Text
showCallStack
where
showCallStack :: Text
showCallStack :: Text
showCallStack = case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
cs of
[] -> "<unknown loc>"
[(name :: String
name, loc :: SrcLoc
loc)] -> String -> SrcLoc -> Text
showLoc String
name SrcLoc
loc
(_, loc :: SrcLoc
loc) : (callerName :: String
callerName, _) : _ -> String -> SrcLoc -> Text
showLoc String
callerName SrcLoc
loc
square :: a -> a
square t :: a
t = "[" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
t a -> a -> a
forall a. Semigroup a => a -> a -> a
<> "] "
showLoc :: String -> SrcLoc -> Text
showLoc :: String -> SrcLoc -> Text
showLoc name :: String
name SrcLoc{..} =
String -> Text
forall a. ToText a => a -> Text
toText String
srcLocModule Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. ToText a => a -> Text
toText String
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
srcLocStartLine
fmtRichMessageDefault :: Message -> IO Text
fmtRichMessageDefault :: Message -> IO Text
fmtRichMessageDefault =
Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> (Message -> Text) -> Message -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Text
formatRichMessage
where
formatRichMessage :: Message -> Text
formatRichMessage :: Message -> Text
formatRichMessage Message{..} =
Severity -> Text
showSeverity Severity
msgSeverity
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CallStack -> Text
showSourceLoc CallStack
msgStack
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msgText
logByteStringStdout :: LogAction IO ByteString
logByteStringStdout :: LogAction IO ByteString
logByteStringStdout = (ByteString -> IO ()) -> LogAction IO ByteString
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction ByteString -> IO ()
BS8.putStrLn
richMessageAction :: LogAction IO Message
richMessageAction :: LogAction IO Message
richMessageAction =
(Message -> IO ByteString)
-> LogAction IO ByteString -> LogAction IO Message
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> LogAction m b -> LogAction m a
cmapM ((Text -> ByteString) -> IO Text -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (IO Text -> IO ByteString)
-> (Message -> IO Text) -> Message -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> IO Text
fmtRichMessageDefault) LogAction IO ByteString
logByteStringStdout
{-# INLINE richMessageAction #-}
log ::
HasCallStack =>
Member (Colog.Log Message) r =>
Severity ->
Text ->
Sem r ()
log :: Severity -> Text -> Sem r ()
log severity :: Severity
severity text :: Text
text =
Message -> Sem r ()
forall msg (r :: [(* -> *) -> * -> *]).
Member (Log msg) r =>
msg -> Sem r ()
Colog.log (Severity -> CallStack -> Text -> Message
Message Severity
severity CallStack
stack Text
text)
where
stack :: CallStack
stack =
CallStack -> CallStack
popCallStack (CallStack -> CallStack
popCallStack CallStack
HasCallStack => CallStack
callStack)
interpretLogNull ::
InterpreterFor Log r
interpretLogNull :: Sem (Log : r) a -> Sem r a
interpretLogNull =
(forall x (rInitial :: [(* -> *) -> * -> *]).
Log (Sem rInitial) x -> Sem r x)
-> Sem (Log : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (rInitial :: [(* -> *) -> * -> *]).
e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret \case
Debug _ -> Sem r x
forall (f :: * -> *). Applicative f => f ()
unit
Info _ -> Sem r x
forall (f :: * -> *). Applicative f => f ()
unit
Warn _ -> Sem r x
forall (f :: * -> *). Applicative f => f ()
unit
Error _ -> Sem r x
forall (f :: * -> *). Applicative f => f ()
unit
ErrorPlus _ _ -> Sem r x
forall (f :: * -> *). Applicative f => f ()
unit
{-# INLINE interpretLogNull #-}
runCologStdout ::
Member (Embed IO) r =>
InterpreterFor (Colog.Log Message) r
runCologStdout :: InterpreterFor (Log Message) r
runCologStdout =
LogAction IO Message -> Sem (Log Message : r) a -> Sem r a
forall (m :: * -> *) msg (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
LogAction m msg -> Sem (Log msg : r) a -> Sem r a
runLogAction @IO LogAction IO Message
richMessageAction
{-# INLINE runCologStdout #-}
toColog ::
HasCallStack =>
Member (Colog.Log Message) r =>
Sem (Log : r) a ->
Sem r a
toColog :: Sem (Log : r) a -> Sem r a
toColog =
(forall x (rInitial :: [(* -> *) -> * -> *]).
Log (Sem rInitial) x -> Sem r x)
-> Sem (Log : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (rInitial :: [(* -> *) -> * -> *]).
e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret \case
Debug msg ->
Severity -> Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
(HasCallStack, Member (Log Message) r) =>
Severity -> Text -> Sem r ()
log Severity
Severity.Debug Text
msg
Info msg ->
Severity -> Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
(HasCallStack, Member (Log Message) r) =>
Severity -> Text -> Sem r ()
log Severity
Severity.Info Text
msg
Warn msg ->
Severity -> Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
(HasCallStack, Member (Log Message) r) =>
Severity -> Text -> Sem r ()
log Severity
Severity.Warning Text
msg
Error msg ->
Severity -> Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
(HasCallStack, Member (Log Message) r) =>
Severity -> Text -> Sem r ()
log Severity
Severity.Error Text
msg
ErrorPlus msg detailed ->
Severity -> Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
(HasCallStack, Member (Log Message) r) =>
Severity -> Text -> Sem r ()
log Severity
Severity.Error Text
msg Sem r () -> Sem r () -> Sem r ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> Sem r ()) -> t Text -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Severity -> Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
(HasCallStack, Member (Log Message) r) =>
Severity -> Text -> Sem r ()
log Severity
Severity.Debug) t Text
detailed
{-# INLINE toColog #-}
interpretLogStdout ::
Member (Embed IO) r =>
Sem (Log : r) a ->
Sem r a
interpretLogStdout :: Sem (Log : r) a -> Sem r a
interpretLogStdout =
Sem (Log Message : r) a -> Sem r a
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
InterpreterFor (Log Message) r
runCologStdout (Sem (Log Message : r) a -> Sem r a)
-> (Sem (Log : r) a -> Sem (Log Message : r) a)
-> Sem (Log : r) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Log : Log Message : r) a -> Sem (Log Message : r) a
forall (r :: [(* -> *) -> * -> *]) a.
(HasCallStack, Member (Log Message) r) =>
Sem (Log : r) a -> Sem r a
toColog (Sem (Log : Log Message : r) a -> Sem (Log Message : r) a)
-> (Sem (Log : r) a -> Sem (Log : Log Message : r) a)
-> Sem (Log : r) a
-> Sem (Log Message : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Log : r) a -> Sem (Log : Log Message : r) a
forall (e2 :: (* -> *) -> * -> *) (e1 :: (* -> *) -> * -> *)
(r :: [(* -> *) -> * -> *]) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder
{-# INLINE interpretLogStdout #-}