module Katip.Scribes.Handle where
import Control.Applicative as A
import Control.Concurrent
import Control.Exception (bracket_)
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 System.IO
import System.IO.Unsafe (unsafePerformIO)
import Katip.Core
import Katip.Format.Time (formatAsLogTime)
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
lock <- newMVar ()
return $ Scribe $ \ i@Item{..} -> do
when (permitItem sev i) $ bracket_ (takeMVar lock) (putMVar lock ()) $
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 = fromText (formatAsLogTime _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