@@ -3,42 +3,33 @@ module Katip.Scribes.Handle where
33-------------------------------------------------------------------------------
44import Control.Applicative as A
55import Control.Concurrent
6−import Control.Exception (finally)
6+import Control.Exception (bracket_, finally)
77import Data.Aeson
8−import Data.Aeson.Text
9−import Data.ByteString.Builder as B
10−import Data.ByteString.Lazy as BL (hPutStr)
11−import Data.ByteString.Lazy.Char8 as BL (singleton)
8+import Data.Text.Lazy (toStrict)
9+import Data.Text.Lazy.Encoding (decodeUtf8)
10+import qualified Data.HashMap.Strict as HM
1211import Data.Monoid as M
1312import Data.Scientific as S
1413import Data.Text (Text)
15−import Data.Text.Lazy.Builder as TL
16−import Data.Text.Lazy.Encoding (encodeUtf8)
14+import Data.Text.Lazy.Builder
15+import Data.Text.Lazy.IO as T
1716import System.IO
18−import qualified Data.HashMap.Strict as HM
19−
2017-------------------------------------------------------------------------------
2118import Katip.Core
2219import Katip.Format.Time (formatAsLogTime)
23−import Katip.Scribes.Handle.FileOwner
2420-------------------------------------------------------------------------------
2521
2622
2723-------------------------------------------------------------------------------
28−brackets :: TL.Builder -> TL.Builder
24+brackets :: Builder -> Builder
2925brackets m = fromText "[" M.<> m <> fromText "]"
3026
31−textBuilderToBS :: TL.Builder -> B.Builder
32−textBuilderToBS = B.lazyByteString . encodeUtf8 . toLazyText
33−
34−appendNL :: B.Builder -> B.Builder
35−appendNL b = b <> B.lazyByteString (BL.singleton '\n')
3627
3728-------------------------------------------------------------------------------
38−getKeys :: LogItem s => Verbosity -> s -> [TL.Builder]
29+getKeys :: LogItem s => Verbosity -> s -> [Builder]
3930getKeys verb a = concat (renderPair A.<$> HM.toList (payloadObject verb a))
4031 where
41− renderPair :: (Text, Value) -> [TL.Builder]
32+ renderPair :: (Text, Value) -> [Builder]
4233 renderPair (k,v) =
4334 case v of
4435 Object o -> concat [renderPair (k <> "." <> k', v') | (k', v') <- HM.toList o]
@@ -74,19 +65,6 @@ data ColorStrategy
7465mkHandleScribe :: ColorStrategy -> Handle -> PermitFunc -> Verbosity -> IO Scribe
7566mkHandleScribe = mkHandleScribeWithFormatter bracketFormat
7667
77−
78−mkFileScribeWithFormatter :: (forall a . LogItem a => ItemFormatter a)
79− -> ColorStrategy
80− -> FilePath
81− -> PermitFunc
82− -> Verbosity
83− -> IO Scribe
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)
88−
89−
9068-- | Logs to a file handle such as stdout, stderr, or a file. Takes a custom
9169-- `ItemFormatter` that can be used to format `Item` as needed.
9270--
@@ -99,34 +77,16 @@ mkHandleScribeWithFormatter :: (forall a . LogItem a => ItemFormatter a)
9977 -> Verbosity
10078 -> IO Scribe
10179mkHandleScribeWithFormatter itemFormatter cs h permitF verb = do
80+ hSetBuffering h LineBuffering
10281 colorize <- case cs of
10382 ColorIfTerminal -> hIsTerminalDevice h
10483 ColorLog b -> return b
10584 lock <- newMVar ()
106− let logger i@Item{..} = withMVar lock $ \() -> do
107− BL.hPutStr h $ toLazyByteString $ itemFormatter colorize verb i
85+ let logger i@Item{..} = do
86+ bracket_ (takeMVar lock) (putMVar lock ()) $
87+ T.hPutStrLn h $ toLazyText $ itemFormatter colorize verb i
10888 return $ Scribe logger (hFlush h) permitF
10989
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)
114− -> ColorStrategy
115− -> FileOwner
116− -> PermitFunc
117− -> Verbosity
118− -> IO Scribe
119−mkFileOwnerScribeWithFormatter itemFormatter cs owner permitF verb = do
120− let
121− colorize = case cs of
122− ColorIfTerminal -> False
123− -- File is never a terminal
124− ColorLog b -> b
125− logger item = do
126− writeFileOwner owner $ toLazyByteString
127− $ itemFormatter colorize verb item
128− scribe = Scribe logger (fileOwnerControl owner CloseMsg) permitF
129− return scribe
13090
13191-------------------------------------------------------------------------------
13292-- | A specialization of 'mkHandleScribe' that takes a 'FilePath'
@@ -135,17 +95,19 @@ mkFileOwnerScribeWithFormatter itemFormatter cs owner permitF verb = do
13595-- 'closeScribe'/'closeScribes'. Does not do log coloring. Sets handle
13696-- to 'LineBuffering' mode.
13797mkFileScribe :: FilePath -> PermitFunc -> Verbosity -> IO Scribe
138−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)
139102
140103
141104-------------------------------------------------------------------------------
142105-- | A custom ItemFormatter for logging `Item`s. Takes a `Bool` indicating
143106-- whether to colorize the output, `Verbosity` of output, and an `Item` to
144−-- format. Note that formatter is responsible for appending the newline at the
145−-- end of the string if required
107+-- format.
146108--
147109-- See `bracketFormat` and `jsonFormat` for examples.
148−type ItemFormatter a = Bool -> Verbosity -> Item a -> B.Builder
110+type ItemFormatter a = Bool -> Verbosity -> Item a -> Builder
149111
150112
151113formatItem :: LogItem a => ItemFormatter a
@@ -159,10 +121,10 @@ formatItem = bracketFormat
159121-- > [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
160122-- > [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
161123bracketFormat :: LogItem a => ItemFormatter a
162−bracketFormat withColor verb Item{..} = appendNL $ textBuilderToBS $
124+bracketFormat withColor verb Item{..} =
163125 brackets nowStr <>
164126 brackets (mconcat $ map fromText $ intercalateNs _itemNamespace) <>
165− brackets (renderSeverity' _itemSeverity) <>
127+ brackets (fromText (renderSeverity' _itemSeverity)) <>
166128 brackets (fromString _itemHost) <>
167129 brackets ("PID " <> fromString (show _itemProcess)) <>
168130 brackets ("ThreadId " <> fromText (getThreadIdText _itemThread)) <>
@@ -173,7 +135,7 @@ bracketFormat withColor verb Item{..} = appendNL $ textBuilderToBS $
173135 nowStr = fromText (formatAsLogTime _itemTime)
174136 ks = map brackets $ getKeys verb _itemPayload
175137 renderSeverity' severity =
176− colorBySeverity withColor severity (fromText $ renderSeverity severity)
138+ colorBySeverity withColor severity (renderSeverity severity)
177139
178140-- | Logs items as JSON. This can be useful in circumstances where you already
179141-- have infrastructure that is expecting JSON to be logged to a standard stream
@@ -183,15 +145,15 @@ bracketFormat withColor verb Item{..} = appendNL $ textBuilderToBS $
183145-- > {"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"}
184146-- > {"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"}
185147jsonFormat :: LogItem a => ItemFormatter a
186−jsonFormat withColor verb i = appendNL $
187− textBuilderToBS $
148+jsonFormat withColor verb i =
149+ fromText $
188150 colorBySeverity withColor (_itemSeverity i) $
189− encodeToTextBuilder $ itemJson verb i
151+ toStrict $ decodeUtf8 $ encode $ itemJson verb i
190152
191153-- | Color a text message based on `Severity`. `ErrorS` and more severe errors
192154-- are colored red, `WarningS` is colored yellow, and all other messages are
193155-- rendered in the default color.
194−colorBySeverity :: Bool -> Severity -> TL.Builder -> TL.Builder
156+colorBySeverity :: Bool -> Severity -> Text -> Text
195157colorBySeverity withColor severity msg = case severity of
196158 EmergencyS -> red msg
197159 AlertS -> red msg