@@ -15,21 +15,42 @@ import Control.AutoUpdate
1515import Control.Concurrent
1616import Control.Lens
1717import Control.Monad.Reader
18−import Data.Aeson (ToJSON)
19−import qualified Data.Aeson as A
20−import qualified Data.Map.Strict as M
18+import Data.Aeson (ToJSON (..))
19+import qualified Data.Aeson as A
20+import Data.Aeson.Lens
21+import qualified Data.HashMap.Strict as HM
22+import Data.List
23+import qualified Data.Map.Strict as M
2124import Data.Monoid
2225import Data.String
23−import Data.Text (Text)
26+import Data.String.Conv
27+import Data.Text (Text)
28+import qualified Data.Text as T
2429import Data.Time
25−import GHC.Generics hiding (to)
30+import GHC.Generics hiding (to)
31+import Language.Haskell.TH
32+import qualified Language.Haskell.TH.Syntax as TH
2633import Network.HostName
34+import System.Posix
2735-------------------------------------------------------------------------------
2836
2937
30−newtype AppName = AppName { getAppName :: Text }
31− deriving (Eq,Show,Read,Ord,Generic,ToJSON,IsString)
38+-------------------------------------------------------------------------------
39+newtype Namespace = Namespace { getNamespace :: [Text] }
40+ deriving (Eq,Show,Read,Ord,Generic,ToJSON,Monoid)
41+
42+instance IsString Namespace where
43+ fromString s = Namespace [fromString s]
44+
45+
46+-------------------------------------------------------------------------------
47+-- | Ready namespace for emission with dots to join the segments.
48+intercalateNs :: Namespace -> [Text]
49+intercalateNs (Namespace xs) = intersperse "." xs
50+
3251
52+-------------------------------------------------------------------------------
53+-- | Application environment, like @prod@, @devel@, @testing@.
3354newtype Environment = Environment { getEnvironment :: Text }
3455 deriving (Eq,Show,Read,Ord,Generic,ToJSON,IsString)
3556
@@ -47,6 +68,18 @@ data Severity
4768 deriving (Eq, Ord, Show, Read, Generic)
4869
4970
71+-------------------------------------------------------------------------------
72+-- | Verbosity controls the amount of information (columns) a 'Scribe'
73+-- emits during logging.
74+--
75+-- The convention is:
76+-- - 'V0' implies no additional payload information is included in message.
77+-- - 'V3' implies the maximum amount of payload information.
78+-- - Anything in between is left to the discretion of the developer.
79+data Verbosity = V0 | V1 | V2 | V3
80+ deriving (Eq, Ord, Show, Read, Generic)
81+
82+
5083-------------------------------------------------------------------------------
5184renderSeverity :: Severity -> Text
5285renderSeverity s = case s of
@@ -68,15 +101,18 @@ instance ToJSON Severity where
68101-------------------------------------------------------------------------------
69102-- | This has everything each log message will contain.
70103data Item a = Item {
71− itemApp :: AppName
72− , itemEnv :: Environment
73− , itemSeverity :: Severity
74− , itemThread :: ThreadId
75− , itemHost :: HostName
76− , itemPayload :: a
77− , itemMessage :: Text
78− , itemTime :: UTCTime
79− } deriving (Show,Generic)
104+ itemApp :: Namespace
105+ , itemEnv :: Environment
106+ , itemSeverity :: Severity
107+ , itemThread :: ThreadId
108+ , itemHost :: HostName
109+ , itemProcess :: ProcessID
110+ , itemPayload :: a
111+ , itemMessage :: Text
112+ , itemTime :: UTCTime
113+ , itemNamespace :: Namespace
114+ , itemLoc :: Maybe Loc
115+ } deriving (Generic)
80116
81117
82118
@@ -87,22 +123,38 @@ instance ToJSON a => ToJSON (Item a) where
87123 , "sev" A..= itemSeverity
88124 , "thread" A..= show itemThread
89125 , "host" A..= itemHost
126+ , "pid" A..= A.String (toS (show itemProcess))
90127 , "data" A..= itemPayload
91128 , "msg" A..= itemMessage
92129 , "at" A..= itemTime
130+ , "ns" A..= itemNamespace
93131 ]
94132
95133
134+-------------------------------------------------------------------------------
135+-- | Field selector by verbosity within JSON payload.
136+data PayloadSelection
137+ = AllKeys
138+ | SomeKeys [Text]
139+
96140-------------------------------------------------------------------------------
97141-- | Payload objects need instances of this class.
98142class ToJSON a => LogContext a where
99143
100− -- | List of keys in the JSON object that should be printed in
101− -- summarizing human-readable output.
102− importantKeys :: a -> [Text]
144+ -- | List of keys in the JSON object that should be included in message.
145+ payloadKeys :: Verbosity -> a -> PayloadSelection
103146
104147
105−instance LogContext () where importantKeys _ = []
148+instance LogContext () where payloadKeys _ _ = SomeKeys []
149+
150+
151+-------------------------------------------------------------------------------
152+-- | Constrain payload based on verbosity. To be used by backends.
153+payloadJson :: LogContext a => Verbosity -> a -> A.Value
154+payloadJson v a = case payloadKeys v a of
155+ AllKeys -> toJSON a
156+ SomeKeys ks -> toJSON a
157+ & _Object %~ HM.filterWithKey (\ k v -> k `elem` ks)
106158
107159
108160-------------------------------------------------------------------------------
@@ -122,7 +174,8 @@ instance Monoid Scribe where
122174-------------------------------------------------------------------------------
123175data LogEnv = LogEnv {
124176 _logEnvHost :: HostName
125− , _logEnvApp :: AppName
177+ , _logEnvPid :: ProcessID
178+ , _logEnvApp :: Namespace
126179 , _logEnvEnv :: Environment
127180 , _logEnvTimer :: IO UTCTime
128181 , _logEnvHandlers :: M.Map Text Scribe
@@ -131,9 +184,15 @@ makeLenses ''LogEnv
131184
132185
133186-------------------------------------------------------------------------------
134−initLogEnv :: AppName -> Environment -> IO LogEnv
187+initLogEnv
188+ :: Namespace
189+ -- ^ A base namespace for this application
190+ -> Environment
191+ -- ^ Current run environment (e.g. @prod@ vs. @devel@)
192+ -> IO LogEnv
135193initLogEnv an env = LogEnv
136194 <$> getHostName
195+ <*> getProcessID
137196 <*> pure an
138197 <*> pure env
139198 <*> mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime }
@@ -164,18 +223,17 @@ class Katip m where
164223 getLogEnv :: m LogEnv
165224
166225
167−
168226-------------------------------------------------------------------------------
169−-- | The generic *full* logging function.
170−logF
171− :: (Applicative m, MonadIO m, LogContext a, Katip m)
172− => Severity
173− -> a
174− -- ^ Contextual payload for the log
175− -> Text
176− -- ^ The log message
177− -> m ()
178−logF sev a msg = do
227+-- | Log with everything, including a source code location.
228+logI
229+ :: (Applicative m, MonadIO m, LogContext a, Katip m)
230+ => a
231+ -> Namespace
232+ -> Maybe Loc
233+ -> Severity
234+ -> Text
235+ -> m ()
236+logI a ns loc sev msg = do
179237 LogEnv{..} <- getLogEnv
180238 item <- Item
181239 <$> pure _logEnvApp
@@ -183,14 +241,96 @@ logF sev a msg = do
183241 <*> pure sev
184242 <*> liftIO myThreadId
185243 <*> pure _logEnvHost
244+ <*> pure _logEnvPid
186245 <*> pure a
187246 <*> pure msg
188247 <*> liftIO _logEnvTimer
248+ <*> pure (_logEnvApp <> ns)
249+ <*> pure loc
189250 liftIO $ forM_ (M.elems _logEnvHandlers) $ \ (Scribe h) -> h item
190251
191252
192253-------------------------------------------------------------------------------
193−-- | Log a message without any context.
194−logM :: (Applicative m, MonadIO m, Katip m) => Severity -> Text -> m ()
195−logM sev msg = logF sev () msg
254+-- | Log with full context.
255+logF
256+ :: (Applicative m, MonadIO m, LogContext a, Katip m)
257+ => a
258+ -- ^ Contextual payload for the log
259+ -> Namespace
260+ -- ^ Specific namespace of the message.
261+ -> Severity
262+ -- ^ Severity of the message
263+ -> Text
264+ -- ^ The log message
265+ -> m ()
266+logF a ns sev msg = logI a ns Nothing sev msg
267+
268+
269+-------------------------------------------------------------------------------
270+-- | Log a message without any payload/context.
271+logM
272+ :: (Applicative m, MonadIO m, Katip m)
273+ => Namespace
274+ -> Severity
275+ -> Text
276+ -> m ()
277+logM ns sev msg = logF () ns sev msg
278+
279+
280+instance TH.Lift Namespace where
281+ lift (Namespace xs) =
282+ let xs' = map T.unpack xs
283+ in [| Namespace (map T.pack xs') |]
284+
285+
286+instance TH.Lift Verbosity where
287+ lift V0 = [| V0 |]
288+ lift V1 = [| V1 |]
289+ lift V2 = [| V2 |]
290+ lift V3 = [| V3 |]
291+
292+
293+instance TH.Lift Severity where
294+ lift Debug = [| Debug |]
295+ lift Info = [| Info |]
296+ lift Notice = [| Notice |]
297+ lift Warning = [| Warning |]
298+ lift Error = [| Error |]
299+ lift Critical = [| Critical |]
300+ lift Alert = [| Alert |]
301+ lift Emergency = [| Emergency |]
302+
303+
304+-- | Lift a location into an Exp.
305+liftLoc :: Loc -> Q Exp
306+liftLoc (Loc a b c (d1, d2) (e1, e2)) = [|Loc
307+ $(TH.lift a)
308+ $(TH.lift b)
309+ $(TH.lift c)
310+ ($(TH.lift d1), $(TH.lift d2))
311+ ($(TH.lift e1), $(TH.lift e2))
312+ |]
313+
196314
315+-------------------------------------------------------------------------------
316+-- | For use when you want to include location in your logs. This will
317+-- fill the 'Maybe Loc' gap in 'logF' of this module.
318+getLoc :: Q Exp
319+getLoc = [| $(location >>= liftLoc) |]
320+
321+
322+-------------------------------------------------------------------------------
323+-- | 'Loc'-tagged logging when using template-haskell is OK.
324+logT :: ExpQ
325+logT = [| \ a ns sev msg -> logI a ns (Just $(location >>= liftLoc)) sev msg |]
326+
327+
328+-- taken from the file-location package
329+-- turn the TH Loc loaction information into a human readable string
330+-- leaving out the loc_end parameter
331+locationToString :: Loc -> String
332+locationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++
333+ ' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc)
334+ where
335+ line = show . fst . loc_start
336+ char = show . snd . loc_start