@@ -0,0 +1,221 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE RankNTypes #-}
3+{-# LANGUAGE RecordWildCards #-}
4+module Katip.Scribes.SyncHandle where
5+
6+-------------------------------------------------------------------------------
7+import Control.Applicative as A
8+import Control.Concurrent
9+import Control.Exception (finally)
10+import Data.Aeson
11+import Data.Aeson.Text
12+import Data.ByteString.Builder as B
13+import Data.ByteString.Lazy as BL (hPutStr)
14+import Data.ByteString.Lazy.Char8 as BL (singleton)
15+import Data.Monoid as M
16+import Data.Scientific as S
17+import Data.Text (Text)
18+import Data.Text.Lazy.Builder as TL
19+import Data.Text.Lazy.Encoding (encodeUtf8)
20+import System.IO
21+import qualified Data.HashMap.Strict as HM
22+
23+-------------------------------------------------------------------------------
24+import Katip.Core
25+import Katip.Format.Time (formatAsLogTime)
26+import Katip.Scribes.SyncHandle.FileOwner
27+-------------------------------------------------------------------------------
28+
29+
30+-------------------------------------------------------------------------------
31+brackets :: TL.Builder -> TL.Builder
32+brackets m = fromText "[" M.<> m <> fromText "]"
33+
34+textBuilderToBS :: TL.Builder -> B.Builder
35+textBuilderToBS = B.lazyByteString . encodeUtf8 . toLazyText
36+
37+appendNL :: B.Builder -> B.Builder
38+appendNL b = b <> B.lazyByteString (BL.singleton '\n')
39+
40+-------------------------------------------------------------------------------
41+getKeys :: LogItem s => Verbosity -> s -> [TL.Builder]
42+getKeys verb a = concat (renderPair A.<$> HM.toList (payloadObject verb a))
43+ where
44+ renderPair :: (Text, Value) -> [TL.Builder]
45+ renderPair (k,v) =
46+ case v of
47+ Object o -> concat [renderPair (k <> "." <> k', v') | (k', v') <- HM.toList o]
48+ String t -> [fromText (k <> ":" <> t)]
49+ Number n -> [fromText (k <> ":") <> fromString (formatNumber n)]
50+ Bool b -> [fromText (k <> ":") <> fromString (show b)]
51+ Null -> [fromText (k <> ":null")]
52+ _ -> mempty -- Can't think of a sensible way to handle arrays
53+ formatNumber :: Scientific -> String
54+ formatNumber n =
55+ formatScientific Generic (if isFloating n then Nothing else Just 0) n
56+
57+
58+-------------------------------------------------------------------------------
59+data ColorStrategy
60+ = ColorLog Bool
61+ -- ^ Whether to use color control chars in log output
62+ | ColorIfTerminal
63+ -- ^ Color if output is a terminal
64+ deriving (Show, Eq)
65+
66+-------------------------------------------------------------------------------
67+-- | Logs to a file handle such as stdout, stderr, or a file. Contexts
68+-- and other information will be flattened out into bracketed
69+-- fields. For example:
70+--
71+-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:32:7] Started
72+-- > [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
73+-- > [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
74+--
75+-- Returns the newly-created `Scribe`. The finalizer flushes the
76+-- handle. Handle mode is set to 'LineBuffering' automatically.
77+mkHandleScribe :: ColorStrategy -> Handle -> PermitFunc -> Verbosity -> IO Scribe
78+mkHandleScribe = mkHandleScribeWithFormatter bracketFormat
79+
80+
81+mkFileScribeWithFormatter :: (forall a . LogItem a => ItemFormatter a)
82+ -> ColorStrategy
83+ -> FilePath
84+ -> PermitFunc
85+ -> Verbosity
86+ -> IO Scribe
87+mkFileScribeWithFormatter formatter color f permitF verb = do
88+ h <- openBinaryFile f AppendMode
89+ Scribe logger finalizer permit <- mkHandleScribeWithFormatter formatter color h permitF verb
90+ return (Scribe logger (finalizer `finally` hClose h) permit)
91+
92+
93+-- | Logs to a file handle such as stdout, stderr, or a file. Takes a custom
94+-- `ItemFormatter` that can be used to format `Item` as needed.
95+--
96+-- Returns the newly-created `Scribe`. The finalizer flushes the
97+-- handle. Handle mode is set to 'LineBuffering' automatically.
98+mkHandleScribeWithFormatter :: (forall a . LogItem a => ItemFormatter a)
99+ -> ColorStrategy
100+ -> Handle
101+ -> PermitFunc
102+ -> Verbosity
103+ -> IO Scribe
104+mkHandleScribeWithFormatter itemFormatter cs h permitF verb = do
105+ colorize <- case cs of
106+ ColorIfTerminal -> hIsTerminalDevice h
107+ ColorLog b -> return b
108+ lock <- newMVar ()
109+ let logger i@Item{..} = withMVar lock $ \() -> do
110+ BL.hPutStr h $ toLazyByteString $ itemFormatter colorize verb i
111+ return $ Scribe logger (hFlush h) permitF
112+
113+-- | Just like mkFileScribeWithFormatter but does it with FileOwner. You can
114+-- rotate your logs with commands to the FileOwner directly. This scribe will
115+-- send messages to the given FileOwner
116+mkFileOwnerScribeWithFormatter :: (forall a . LogItem a => ItemFormatter a)
117+ -> ColorStrategy
118+ -> FileOwner
119+ -> PermitFunc
120+ -> Verbosity
121+ -> IO Scribe
122+mkFileOwnerScribeWithFormatter itemFormatter cs owner permitF verb = do
123+ let
124+ colorize = case cs of
125+ ColorIfTerminal -> False
126+ -- File is never a terminal
127+ ColorLog b -> b
128+ logger item = do
129+ writeFileOwner owner $ toLazyByteString
130+ $ itemFormatter colorize verb item
131+ scribe = Scribe logger (fileOwnerControl owner CloseMsg) permitF
132+ return scribe
133+
134+-------------------------------------------------------------------------------
135+-- | A specialization of 'mkHandleScribe' that takes a 'FilePath'
136+-- instead of a 'Handle'. It is responsible for opening the file in
137+-- 'AppendMode' and will close the file handle on
138+-- 'closeScribe'/'closeScribes'. Does not do log coloring. Sets handle
139+-- to 'LineBuffering' mode.
140+mkFileScribe :: FilePath -> PermitFunc -> Verbosity -> IO Scribe
141+mkFileScribe = mkFileScribeWithFormatter bracketFormat (ColorLog False)
142+
143+
144+-------------------------------------------------------------------------------
145+-- | A custom ItemFormatter for logging `Item`s. Takes a `Bool` indicating
146+-- whether to colorize the output, `Verbosity` of output, and an `Item` to
147+-- format. Note that formatter is responsible for appending the newline at the
148+-- end of the string if required
149+--
150+-- See `bracketFormat` and `jsonFormat` for examples.
151+type ItemFormatter a = Bool -> Verbosity -> Item a -> B.Builder
152+
153+
154+formatItem :: LogItem a => ItemFormatter a
155+formatItem = bracketFormat
156+{-# DEPRECATED formatItem "Use bracketFormat instead" #-}
157+
158+-- | A traditional 'bracketed' log format. Contexts and other information will
159+-- be flattened out into bracketed fields. For example:
160+--
161+-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:32:7] Started
162+-- > [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
163+-- > [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
164+bracketFormat :: LogItem a => ItemFormatter a
165+bracketFormat withColor verb Item{..} = appendNL $ textBuilderToBS $
166+ brackets nowStr <>
167+ brackets (mconcat $ map fromText $ intercalateNs _itemNamespace) <>
168+ brackets (renderSeverity' _itemSeverity) <>
169+ brackets (fromString _itemHost) <>
170+ brackets ("PID " <> fromString (show _itemProcess)) <>
171+ brackets ("ThreadId " <> fromText (getThreadIdText _itemThread)) <>
172+ mconcat ks <>
173+ maybe mempty (brackets . fromString . locationToString) _itemLoc <>
174+ fromText " " <> (unLogStr _itemMessage)
175+ where
176+ nowStr = fromText (formatAsLogTime _itemTime)
177+ ks = map brackets $ getKeys verb _itemPayload
178+ renderSeverity' severity =
179+ colorBySeverity withColor severity (fromText $ renderSeverity severity)
180+
181+-- | Logs items as JSON. This can be useful in circumstances where you already
182+-- have infrastructure that is expecting JSON to be logged to a standard stream
183+-- or file. For example:
184+--
185+-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp"],"data":{},"app":["MyApp"],"msg":"Started","pid":"10456","loc":{"loc_col":9,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":44},"host":"myhost.example.com","sev":"Info","thread":"ThreadId 139"}
186+-- > {"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"}
187+-- > {"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"}
188+jsonFormat :: LogItem a => ItemFormatter a
189+jsonFormat withColor verb i = appendNL $
190+ textBuilderToBS $
191+ colorBySeverity withColor (_itemSeverity i) $
192+ encodeToTextBuilder $ itemJson verb i
193+
194+-- | Color a text message based on `Severity`. `ErrorS` and more severe errors
195+-- are colored red, `WarningS` is colored yellow, and all other messages are
196+-- rendered in the default color.
197+colorBySeverity :: Bool -> Severity -> TL.Builder -> TL.Builder
198+colorBySeverity withColor severity msg = case severity of
199+ EmergencyS -> red msg
200+ AlertS -> red msg
201+ CriticalS -> red msg
202+ ErrorS -> red msg
203+ WarningS -> yellow msg
204+ _ -> msg
205+ where
206+ red = colorize "31"
207+ yellow = colorize "33"
208+ colorize c s
209+ | withColor = "\ESC["<> c <> "m" <> s <> "\ESC[0m"
210+ | otherwise = s
211+
212+
213+-- | Provides a simple log environment with 1 scribe going to
214+-- stdout. This is a decent example of how to build a LogEnv and is
215+-- best for scripts that just need a quick, reasonable set up to log
216+-- to stdout.
217+ioLogEnv :: PermitFunc -> Verbosity -> IO LogEnv
218+ioLogEnv permit verb = do
219+ le <- initLogEnv "io" "io"
220+ lh <- mkHandleScribe ColorIfTerminal stdout permit verb
221+ registerScribe "stdout" lh defaultScribeSettings le