@@ -3,33 +3,42 @@ 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 (bracket_, finally)
6+import Control.Exception (finally)
7import Data.Aeson
7import Data.Aeson
8−import Data.Text.Lazy (toStrict)
8+import Data.Aeson.Text
9−import Data.Text.Lazy.Encoding (decodeUtf8)
9+import Data.ByteString.Builder as B
10−import qualified Data.HashMap.Strict as HM
10+import Data.ByteString.Lazy as BL (hPutStr)
11+import Data.ByteString.Lazy.Char8 as BL (singleton)
11import Data.Monoid as M
12import Data.Monoid as M
12import Data.Scientific as S
13import Data.Scientific as S
13import Data.Text (Text)
14import Data.Text (Text)
14−import Data.Text.Lazy.Builder
15+import Data.Text.Lazy.Builder as TL
15−import Data.Text.Lazy.IO as T
16+import Data.Text.Lazy.Encoding (encodeUtf8)
16import System.IO
17import System.IO
18+import qualified Data.HashMap.Strict as HM
17-------------------------------------------------------------------------------
20-------------------------------------------------------------------------------
18import Katip.Core
21import Katip.Core
19import Katip.Format.Time (formatAsLogTime)
22import Katip.Format.Time (formatAsLogTime)
23+import Katip.Scribes.Handle.FileOwner
20-------------------------------------------------------------------------------
24-------------------------------------------------------------------------------
23-------------------------------------------------------------------------------
27-------------------------------------------------------------------------------
24−brackets :: Builder -> Builder
28+brackets :: TL.Builder -> TL.Builder
25brackets m = fromText "[" M.<> m <> fromText "]"
29brackets m = fromText "[" M.<> m <> fromText "]"
31+textBuilderToBS :: TL.Builder -> B.Builder
32+textBuilderToBS = B.lazyByteString . encodeUtf8 . toLazyText
34+appendNL :: B.Builder -> B.Builder
35+appendNL b = b <> B.lazyByteString (BL.singleton '\n')
28-------------------------------------------------------------------------------
37-------------------------------------------------------------------------------
29−getKeys :: LogItem s => Verbosity -> s -> [Builder]
38+getKeys :: LogItem s => Verbosity -> s -> [TL.Builder]
30getKeys verb a = concat (renderPair A.<$> HM.toList (payloadObject verb a))
39getKeys verb a = concat (renderPair A.<$> HM.toList (payloadObject verb a))
32− renderPair :: (Text, Value) -> [Builder]
41+ renderPair :: (Text, Value) -> [TL.Builder]
33 renderPair (k,v) =
42 renderPair (k,v) =
35 Object o -> concat [renderPair (k <> "." <> k', v') | (k', v') <- HM.toList o]
44 Object o -> concat [renderPair (k <> "." <> k', v') | (k', v') <- HM.toList o]
@@ -65,6 +74,19 @@ data ColorStrategy
65mkHandleScribe :: ColorStrategy -> Handle -> PermitFunc -> Verbosity -> IO Scribe
74mkHandleScribe :: ColorStrategy -> Handle -> PermitFunc -> Verbosity -> IO Scribe
66mkHandleScribe = mkHandleScribeWithFormatter bracketFormat
75mkHandleScribe = mkHandleScribeWithFormatter bracketFormat
78+mkFileScribeWithFormatter :: (forall a . LogItem a => ItemFormatter a)
84+mkFileScribeWithFormatter formatter color f permitF verb = do
85+ h <- openBinaryFile f AppendMode
86+ Scribe logger finalizer permit <- mkHandleScribeWithFormatter formatter color h permitF verb
87+ return (Scribe logger (finalizer `finally` hClose h) permit)
68-- | Logs to a file handle such as stdout, stderr, or a file. Takes a custom
90-- | Logs to a file handle such as stdout, stderr, or a file. Takes a custom
69-- `ItemFormatter` that can be used to format `Item` as needed.
91-- `ItemFormatter` that can be used to format `Item` as needed.
@@ -77,16 +99,34 @@ mkHandleScribeWithFormatter :: (forall a . LogItem a => ItemFormatter a)
77 -> Verbosity
99 -> Verbosity
78 -> IO Scribe
100 -> IO Scribe
79mkHandleScribeWithFormatter itemFormatter cs h permitF verb = do
101mkHandleScribeWithFormatter itemFormatter cs h permitF verb = do
80− hSetBuffering h LineBuffering
81 colorize <- case cs of
102 colorize <- case cs of
82 ColorIfTerminal -> hIsTerminalDevice h
103 ColorIfTerminal -> hIsTerminalDevice h
83 ColorLog b -> return b
104 ColorLog b -> return b
84 lock <- newMVar ()
105 lock <- newMVar ()
85− let logger i@Item{..} = do
106+ let logger i@Item{..} = withMVar lock $ \() -> do
86− bracket_ (takeMVar lock) (putMVar lock ()) $
87− T.hPutStrLn h $ toLazyText $ itemFormatter colorize verb i
107+ BL.hPutStr h $ toLazyByteString $ itemFormatter colorize verb i
88 return $ Scribe logger (hFlush h) permitF
108 return $ Scribe logger (hFlush h) permitF
110+-- | Just like mkFileScribeWithFormatter but does it with FileOwner. You can
111+-- rotate your logs with commands to the FileOwner directly. This scribe will
112+-- send messages to the given FileOwner
113+mkFileOwnerScribeWithFormatter :: (forall a . LogItem a => ItemFormatter a)
119+mkFileOwnerScribeWithFormatter itemFormatter cs owner permitF verb = do
121+ colorize = case cs of
122+ ColorIfTerminal -> False
123+ -- File is never a terminal
126+ writeFileOwner owner $ toLazyByteString
127+ $ itemFormatter colorize verb item
128+ scribe = Scribe logger (fileOwnerControl owner CloseMsg) permitF
91-------------------------------------------------------------------------------
131-------------------------------------------------------------------------------
92-- | A specialization of 'mkHandleScribe' that takes a 'FilePath'
132-- | A specialization of 'mkHandleScribe' that takes a 'FilePath'
@@ -95,19 +135,17 @@ mkHandleScribeWithFormatter itemFormatter cs h permitF verb = do
95-- 'closeScribe'/'closeScribes'. Does not do log coloring. Sets handle
135-- 'closeScribe'/'closeScribes'. Does not do log coloring. Sets handle
96-- to 'LineBuffering' mode.
136-- to 'LineBuffering' mode.
97mkFileScribe :: FilePath -> PermitFunc -> Verbosity -> IO Scribe
137mkFileScribe :: FilePath -> PermitFunc -> Verbosity -> IO Scribe
98−mkFileScribe f permitF verb = do
138+mkFileScribe = mkFileScribeWithFormatter bracketFormat (ColorLog False)
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)
104-------------------------------------------------------------------------------
141-------------------------------------------------------------------------------
105-- | A custom ItemFormatter for logging `Item`s. Takes a `Bool` indicating
142-- | A custom ItemFormatter for logging `Item`s. Takes a `Bool` indicating
106-- whether to colorize the output, `Verbosity` of output, and an `Item` to
143-- whether to colorize the output, `Verbosity` of output, and an `Item` to
107−-- format.
144+-- format. Note that formatter is responsible for appending the newline at the
145+-- end of the string if required
109-- See `bracketFormat` and `jsonFormat` for examples.
147-- See `bracketFormat` and `jsonFormat` for examples.
110−type ItemFormatter a = Bool -> Verbosity -> Item a -> Builder
148+type ItemFormatter a = Bool -> Verbosity -> Item a -> B.Builder
113formatItem :: LogItem a => ItemFormatter a
151formatItem :: LogItem a => ItemFormatter a
@@ -121,10 +159,10 @@ formatItem = bracketFormat
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
159-- > [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
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
160-- > [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
123bracketFormat :: LogItem a => ItemFormatter a
161bracketFormat :: LogItem a => ItemFormatter a
124−bracketFormat withColor verb Item{..} =
162+bracketFormat withColor verb Item{..} = appendNL $ textBuilderToBS $
125 brackets nowStr <>
163 brackets nowStr <>
126 brackets (mconcat $ map fromText $ intercalateNs _itemNamespace) <>
164 brackets (mconcat $ map fromText $ intercalateNs _itemNamespace) <>
127− brackets (fromText (renderSeverity' _itemSeverity)) <>
165+ brackets (renderSeverity' _itemSeverity) <>
128 brackets (fromString _itemHost) <>
166 brackets (fromString _itemHost) <>
129 brackets ("PID " <> fromString (show _itemProcess)) <>
167 brackets ("PID " <> fromString (show _itemProcess)) <>
130 brackets ("ThreadId " <> fromText (getThreadIdText _itemThread)) <>
168 brackets ("ThreadId " <> fromText (getThreadIdText _itemThread)) <>
@@ -135,7 +173,7 @@ bracketFormat withColor verb Item{..} =
135 nowStr = fromText (formatAsLogTime _itemTime)
173 nowStr = fromText (formatAsLogTime _itemTime)
136 ks = map brackets $ getKeys verb _itemPayload
174 ks = map brackets $ getKeys verb _itemPayload
137 renderSeverity' severity =
175 renderSeverity' severity =
138− colorBySeverity withColor severity (renderSeverity severity)
176+ colorBySeverity withColor severity (fromText $ renderSeverity severity)
140-- | Logs items as JSON. This can be useful in circumstances where you already
178-- | Logs items as JSON. This can be useful in circumstances where you already
141-- have infrastructure that is expecting JSON to be logged to a standard stream
179-- have infrastructure that is expecting JSON to be logged to a standard stream
@@ -145,15 +183,15 @@ bracketFormat withColor verb Item{..} =
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"}
183-- > {"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"}
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"}
184-- > {"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"}
147jsonFormat :: LogItem a => ItemFormatter a
185jsonFormat :: LogItem a => ItemFormatter a
148−jsonFormat withColor verb i =
186+jsonFormat withColor verb i = appendNL $
149− fromText $
187+ textBuilderToBS $
150 colorBySeverity withColor (_itemSeverity i) $
188 colorBySeverity withColor (_itemSeverity i) $
151− toStrict $ decodeUtf8 $ encode $ itemJson verb i
189+ encodeToTextBuilder $ itemJson verb i
153-- | Color a text message based on `Severity`. `ErrorS` and more severe errors
191-- | Color a text message based on `Severity`. `ErrorS` and more severe errors
154-- are colored red, `WarningS` is colored yellow, and all other messages are
192-- are colored red, `WarningS` is colored yellow, and all other messages are
155-- rendered in the default color.
193-- rendered in the default color.
156−colorBySeverity :: Bool -> Severity -> Text -> Text
194+colorBySeverity :: Bool -> Severity -> TL.Builder -> TL.Builder
157colorBySeverity withColor severity msg = case severity of
195colorBySeverity withColor severity msg = case severity of
158 EmergencyS -> red msg
196 EmergencyS -> red msg
159 AlertS -> red msg
197 AlertS -> red msg