module Katip.Scribes.Handle where
import Control.Applicative as A
import Control.Monad
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import Data.Monoid
import Data.Text (Text)
import Data.Text.Lazy.Builder
import Data.Text.Lazy.IO as T
import Data.Time
import qualified Data.Time.Locale.Compat as LC
import System.IO
import System.IO.Unsafe (unsafePerformIO)
import Katip.Core
brackets :: Builder -> Builder
brackets m = fromText "[" <> m <> fromText "]"
getKeys :: LogItem s => Verbosity -> s -> [Builder]
getKeys verb a = concat (renderPair A.<$> HM.toList (payloadObject verb a))
where
renderPair :: (Text, Value) -> [Builder]
renderPair (k,v) =
case v of
Object o -> concat [renderPair (k <> "." <> k', v') | (k', v') <- HM.toList o]
String t -> [fromText (k <> ":" <> t)]
Number n -> [fromText (k <> ":") <> fromString (show n)]
Bool b -> [fromText (k <> ":") <> fromString (show b)]
Null -> [fromText (k <> ":null")]
_ -> mempty
data ColorStrategy
= ColorLog Bool
| ColorIfTerminal
mkHandleScribe :: ColorStrategy -> Handle -> Severity -> Verbosity -> IO Scribe
mkHandleScribe cs h sev verb = do
hSetBuffering h LineBuffering
colorize <- case cs of
ColorIfTerminal -> hIsTerminalDevice h
ColorLog b -> return b
return $ Scribe $ \ i@Item{..} -> do
when (permitItem sev i) $
T.hPutStrLn h $ toLazyText $ formatItem colorize verb i
formatItem :: LogItem a => Bool -> Verbosity -> Item a -> Builder
formatItem withColor verb Item{..} =
brackets nowStr <>
brackets (mconcat $ map fromText $ intercalateNs _itemNamespace) <>
brackets (fromText (renderSeverity' _itemSeverity)) <>
brackets (fromString _itemHost) <>
brackets (fromString (show _itemProcess)) <>
brackets (fromText (getThreadIdText _itemThread)) <>
mconcat ks <>
maybe mempty (brackets . fromString . locationToString) _itemLoc <>
fromText " " <> (unLogStr _itemMessage)
where
nowStr = fromString $ formatTime LC.defaultTimeLocale "%Y-%m-%d %H:%M:%S" _itemTime
ks = map brackets $ getKeys verb _itemPayload
renderSeverity' s = case s of
EmergencyS -> red $ renderSeverity s
AlertS -> red $ renderSeverity s
CriticalS -> red $ renderSeverity s
ErrorS -> red $ renderSeverity s
WarningS -> yellow $ renderSeverity s
_ -> renderSeverity s
red = colorize "31"
yellow = colorize "33"
colorize c s
| withColor = "\ESC["<> c <> "m" <> s <> "\ESC[0m"
| otherwise = s
_ioLogEnv :: LogEnv
_ioLogEnv = unsafePerformIO $ do
le <- initLogEnv "io" "io"
lh <- mkHandleScribe ColorIfTerminal stdout DebugS V3
return $ registerScribe "stdout" lh le