@@ -3,19 +3,17 @@ module Katip.Scribes.Handle where
3-------------------------------------------------------------------------------
3-------------------------------------------------------------------------------
4import Control.Applicative as A
4import Control.Applicative as A
5import Control.Concurrent
5import Control.Concurrent
6−import Control.Exception (finally)
6+import Control.Exception (bracket_, finally)
7import Data.Aeson
7import Data.Aeson
8−import Data.Aeson.Text
8+import Data.Text.Lazy (toStrict)
9−import Data.ByteString.Builder as B
9+import Data.Text.Lazy.Encoding (decodeUtf8)
10−import Data.ByteString.Lazy as BL (hPutStr)
10+import qualified Data.HashMap.Strict as HM
11import Data.Monoid as M
11import Data.Monoid as M
12import Data.Scientific as S
12import Data.Scientific as S
13import Data.Text (Text)
13import Data.Text (Text)
14−import Data.Text.Lazy.Builder as TL
14+import Data.Text.Lazy.Builder
15−import Data.Text.Lazy.Encoding (encodeUtf8)
15+import Data.Text.Lazy.IO as T
16import System.IO
16import System.IO
17−import qualified Data.HashMap.Strict as HM
19-------------------------------------------------------------------------------
17-------------------------------------------------------------------------------
20import Katip.Core
18import Katip.Core
21import Katip.Format.Time (formatAsLogTime)
19import Katip.Format.Time (formatAsLogTime)
@@ -23,20 +21,15 @@ import Katip.Format.Time (formatAsLogTime)
25-------------------------------------------------------------------------------
23-------------------------------------------------------------------------------
26−brackets :: TL.Builder -> TL.Builder
24+brackets :: Builder -> Builder
27brackets m = fromText "[" M.<> m <> fromText "]"
25brackets m = fromText "[" M.<> m <> fromText "]"
29−textBuilderToBS :: TL.Builder -> B.Builder
30−textBuilderToBS = B.lazyByteString . encodeUtf8 . toLazyText
32−appendNL :: TL.Builder -> TL.Builder
33−appendNL b = b <> TL.singleton '\n'
35-------------------------------------------------------------------------------
28-------------------------------------------------------------------------------
36−getKeys :: LogItem s => Verbosity -> s -> [TL.Builder]
29+getKeys :: LogItem s => Verbosity -> s -> [Builder]
37getKeys verb a = concat (renderPair A.<$> HM.toList (payloadObject verb a))
30getKeys verb a = concat (renderPair A.<$> HM.toList (payloadObject verb a))
39− renderPair :: (Text, Value) -> [TL.Builder]
32+ renderPair :: (Text, Value) -> [Builder]
40 renderPair (k,v) =
33 renderPair (k,v) =
42 Object o -> concat [renderPair (k <> "." <> k', v') | (k', v') <- HM.toList o]
35 Object o -> concat [renderPair (k <> "." <> k', v') | (k', v') <- HM.toList o]
@@ -72,19 +65,6 @@ data ColorStrategy
72mkHandleScribe :: ColorStrategy -> Handle -> PermitFunc -> Verbosity -> IO Scribe
65mkHandleScribe :: ColorStrategy -> Handle -> PermitFunc -> Verbosity -> IO Scribe
73mkHandleScribe = mkHandleScribeWithFormatter bracketFormat
66mkHandleScribe = mkHandleScribeWithFormatter bracketFormat
76−mkFileScribeWithFormatter :: (forall a . LogItem a => ItemFormatter a)
82−mkFileScribeWithFormatter formatter color f permitF verb = do
83− h <- openBinaryFile f AppendMode
84− Scribe logger finalizer permit <- mkHandleScribeWithFormatter formatter color h permitF verb
85− return (Scribe logger (finalizer `finally` hClose h) permit)
88-- | Logs to a file handle such as stdout, stderr, or a file. Takes a custom
68-- | Logs to a file handle such as stdout, stderr, or a file. Takes a custom
89-- `ItemFormatter` that can be used to format `Item` as needed.
69-- `ItemFormatter` that can be used to format `Item` as needed.
@@ -97,12 +77,14 @@ mkHandleScribeWithFormatter :: (forall a . LogItem a => ItemFormatter a)
97 -> Verbosity
77 -> Verbosity
98 -> IO Scribe
78 -> IO Scribe
99mkHandleScribeWithFormatter itemFormatter cs h permitF verb = do
79mkHandleScribeWithFormatter itemFormatter cs h permitF verb = do
80+ hSetBuffering h LineBuffering
100 colorize <- case cs of
81 colorize <- case cs of
101 ColorIfTerminal -> hIsTerminalDevice h
82 ColorIfTerminal -> hIsTerminalDevice h
102 ColorLog b -> return b
83 ColorLog b -> return b
103 lock <- newMVar ()
84 lock <- newMVar ()
104− let logger i@Item{..} = withMVar lock $ \() -> do
85+ let logger i@Item{..} = do
86+ bracket_ (takeMVar lock) (putMVar lock ()) $
105− BL.hPutStr h $ toLazyByteString $ itemFormatter colorize verb i
87+ T.hPutStrLn h $ toLazyText $ itemFormatter colorize verb i
106 return $ Scribe logger (hFlush h) permitF
88 return $ Scribe logger (hFlush h) permitF
@@ -113,17 +95,19 @@ mkHandleScribeWithFormatter itemFormatter cs h permitF verb = do
113-- 'closeScribe'/'closeScribes'. Does not do log coloring. Sets handle
95-- 'closeScribe'/'closeScribes'. Does not do log coloring. Sets handle
114-- to 'LineBuffering' mode.
96-- to 'LineBuffering' mode.
115mkFileScribe :: FilePath -> PermitFunc -> Verbosity -> IO Scribe
97mkFileScribe :: FilePath -> PermitFunc -> Verbosity -> IO Scribe
116−mkFileScribe = mkFileScribeWithFormatter bracketFormat (ColorLog False)
98+mkFileScribe f permitF verb = do
99+ h <- openFile f AppendMode
100+ Scribe logger finalizer permit <- mkHandleScribe (ColorLog False) h permitF verb
101+ return (Scribe logger (finalizer `finally` hClose h) permit)
119-------------------------------------------------------------------------------
104-------------------------------------------------------------------------------
120-- | A custom ItemFormatter for logging `Item`s. Takes a `Bool` indicating
105-- | A custom ItemFormatter for logging `Item`s. Takes a `Bool` indicating
121-- whether to colorize the output, `Verbosity` of output, and an `Item` to
106-- whether to colorize the output, `Verbosity` of output, and an `Item` to
122−-- format. Note that formatter is responsible for appending the newline at the
107+-- format.
123−-- end of the string if required
125-- See `bracketFormat` and `jsonFormat` for examples.
109-- See `bracketFormat` and `jsonFormat` for examples.
126−type ItemFormatter a = Bool -> Verbosity -> Item a -> B.Builder
110+type ItemFormatter a = Bool -> Verbosity -> Item a -> Builder
129formatItem :: LogItem a => ItemFormatter a
113formatItem :: LogItem a => ItemFormatter a
@@ -137,10 +121,10 @@ formatItem = bracketFormat
137-- > [2016-05-11 21:01:15][MyApp.confrabulation][Debug][myhost.example.com][PID 1724][ThreadId 1154][confrab_factor:42.0][main:Helpers.Logging Helpers/Logging.hs:41:9] Confrabulating widgets, with extra namespace and context
121-- > [2016-05-11 21:01:15][MyApp.confrabulation][Debug][myhost.example.com][PID 1724][ThreadId 1154][confrab_factor:42.0][main:Helpers.Logging Helpers/Logging.hs:41:9] Confrabulating widgets, with extra namespace and context
138-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:43:7] Namespace and context are back to normal
122-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:43:7] Namespace and context are back to normal
139bracketFormat :: LogItem a => ItemFormatter a
123bracketFormat :: LogItem a => ItemFormatter a
140−bracketFormat withColor verb Item{..} = textBuilderToBS $ appendNL $
124+bracketFormat withColor verb Item{..} =
141 brackets nowStr <>
125 brackets nowStr <>
142 brackets (mconcat $ map fromText $ intercalateNs _itemNamespace) <>
126 brackets (mconcat $ map fromText $ intercalateNs _itemNamespace) <>
143− brackets (renderSeverity' _itemSeverity) <>
127+ brackets (fromText (renderSeverity' _itemSeverity)) <>
144 brackets (fromString _itemHost) <>
128 brackets (fromString _itemHost) <>
145 brackets ("PID " <> fromString (show _itemProcess)) <>
129 brackets ("PID " <> fromString (show _itemProcess)) <>
146 brackets ("ThreadId " <> fromText (getThreadIdText _itemThread)) <>
130 brackets ("ThreadId " <> fromText (getThreadIdText _itemThread)) <>
@@ -151,7 +135,7 @@ bracketFormat withColor verb Item{..} = textBuilderToBS $ appendNL $
151 nowStr = fromText (formatAsLogTime _itemTime)
135 nowStr = fromText (formatAsLogTime _itemTime)
152 ks = map brackets $ getKeys verb _itemPayload
136 ks = map brackets $ getKeys verb _itemPayload
153 renderSeverity' severity =
137 renderSeverity' severity =
154− colorBySeverity withColor severity (fromText $ renderSeverity severity)
138+ colorBySeverity withColor severity (renderSeverity severity)
156-- | Logs items as JSON. This can be useful in circumstances where you already
140-- | Logs items as JSON. This can be useful in circumstances where you already
157-- have infrastructure that is expecting JSON to be logged to a standard stream
141-- have infrastructure that is expecting JSON to be logged to a standard stream
@@ -161,15 +145,15 @@ bracketFormat withColor verb Item{..} = textBuilderToBS $ appendNL $
161-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp","confrabulation"],"data":{"confrab_factor":42},"app":["MyApp"],"msg":"Confrabulating widgets, with extra namespace and context","pid":"10456","loc":{"loc_col":11,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":53},"host":"myhost.example.com","sev":"Debug","thread":"ThreadId 139"}
145-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp","confrabulation"],"data":{"confrab_factor":42},"app":["MyApp"],"msg":"Confrabulating widgets, with extra namespace and context","pid":"10456","loc":{"loc_col":11,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":53},"host":"myhost.example.com","sev":"Debug","thread":"ThreadId 139"}
162-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp"],"data":{},"app":["MyApp"],"msg":"Namespace and context are back to normal","pid":"10456","loc":{"loc_col":9,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":55},"host":"myhost.example.com","sev":"Info","thread":"ThreadId 139"}
146-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp"],"data":{},"app":["MyApp"],"msg":"Namespace and context are back to normal","pid":"10456","loc":{"loc_col":9,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":55},"host":"myhost.example.com","sev":"Info","thread":"ThreadId 139"}
163jsonFormat :: LogItem a => ItemFormatter a
147jsonFormat :: LogItem a => ItemFormatter a
164−jsonFormat withColor verb i = textBuilderToBS $
148+jsonFormat withColor verb i =
165− appendNL $
149+ fromText $
166 colorBySeverity withColor (_itemSeverity i) $
150 colorBySeverity withColor (_itemSeverity i) $
167− encodeToTextBuilder $ itemJson verb i
151+ toStrict $ decodeUtf8 $ encode $ itemJson verb i
169-- | Color a text message based on `Severity`. `ErrorS` and more severe errors
153-- | Color a text message based on `Severity`. `ErrorS` and more severe errors
170-- are colored red, `WarningS` is colored yellow, and all other messages are
154-- are colored red, `WarningS` is colored yellow, and all other messages are
171-- rendered in the default color.
155-- rendered in the default color.
172−colorBySeverity :: Bool -> Severity -> TL.Builder -> TL.Builder
156+colorBySeverity :: Bool -> Severity -> Text -> Text
173colorBySeverity withColor severity msg = case severity of
157colorBySeverity withColor severity msg = case severity of
174 EmergencyS -> red msg
158 EmergencyS -> red msg
175 AlertS -> red msg
159 AlertS -> red msg