@@ -19,6 +19,7 @@ import Data.Aeson (ToJSON)
1919import qualified Data.Aeson as A
2020import qualified Data.Map.Strict as M
2121import Data.Monoid
22+import Data.String
2223import Data.Text (Text)
2324import Data.Time
2425import GHC.Generics hiding (to)
@@ -27,10 +28,10 @@ import Network.HostName
2728
2829
2930newtype AppName = AppName { getAppName :: Text }
30− deriving (Eq,Show,Read,Ord,Generic,ToJSON)
31+ deriving (Eq,Show,Read,Ord,Generic,ToJSON,IsString)
3132
3233newtype Environment = Environment { getEnvironment :: Text }
33− deriving (Eq,Show,Read,Ord,Generic,ToJSON)
34+ deriving (Eq,Show,Read,Ord,Generic,ToJSON,IsString)
3435
3536
3637-------------------------------------------------------------------------------
@@ -63,7 +64,9 @@ renderSeverity s = case s of
6364instance ToJSON Severity where
6465 toJSON s = A.String (renderSeverity s)
6566
67+
6668-------------------------------------------------------------------------------
69+-- | This has everything each log message will contain.
6770data Item a = Item {
6871 itemApp :: AppName
6972 , itemEnv :: Environment
@@ -91,7 +94,9 @@ instance ToJSON a => ToJSON (Item a) where
9194
9295
9396-------------------------------------------------------------------------------
94−data LogHandler = LogHandler {
97+-- | Scribes are handlers of incoming items. Each registered scribe
98+-- knows how to push a log item somewhere.
99+data Scribe = Scribe {
95100 lhPush :: forall a. ToJSON a => Item a -> IO ()
96101 }
97102
@@ -102,7 +107,7 @@ data LogEnv = LogEnv {
102107 , _logEnvApp :: AppName
103108 , _logEnvEnv :: Environment
104109 , _logEnvTimer :: IO UTCTime
105− , _logEnvHandlers :: M.Map Text LogHandler
110+ , _logEnvHandlers :: M.Map Text Scribe
106111 }
107112makeLenses ''LogEnv
108113
@@ -121,7 +126,7 @@ initLogEnv an env = LogEnv
121126registerHandler
122127 :: Text
123128 -- ^ Name the handler
124− -> LogHandler
129+ -> Scribe
125130 -> LogEnv
126131 -> LogEnv
127132registerHandler nm h = logEnvHandlers . at nm .~ Just h
@@ -136,24 +141,38 @@ unregisterHandler
136141unregisterHandler nm = logEnvHandlers . at nm .~ Nothing
137142
138143
144+
145+class Katip m where
146+ getLogEnv :: m LogEnv
147+
148+
149+
139150-------------------------------------------------------------------------------
140−logM
141− :: (Applicative m, MonadIO m, ToJSON a, MonadReader LogEnv m)
151+-- | The generic *full* logging function.
152+logF
153+ :: (Applicative m, MonadIO m, ToJSON a, Katip m)
142154 => Severity
143155 -> a
156+ -- ^ Contextual payload for the log
144157 -> Text
158+ -- ^ The log message
145159 -> m ()
146−logM sev a msg = do
160+logF sev a msg = do
161+ LogEnv{..} <- getLogEnv
147162 item <- Item
148− <$> view logEnvApp
149− <*> view logEnvEnv
163+ <$> pure _logEnvApp
164+ <*> pure _logEnvEnv
150165 <*> pure sev
151166 <*> liftIO myThreadId
152− <*> view logEnvHost
167+ <*> pure _logEnvHost
153168 <*> pure a
154169 <*> pure msg
155− <*> (view logEnvTimer >>= liftIO)
156− hs <- view $ logEnvHandlers . to M.elems
157− liftIO $ forM_ hs $ \ (LogHandler h) -> h item
170+ <*> liftIO _logEnvTimer
171+ liftIO $ forM_ (M.elems _logEnvHandlers) $ \ (Scribe h) -> h item
172+
158173
174+-------------------------------------------------------------------------------
175+-- | Log a message without any context.
176+logM :: (Applicative m, MonadIO m, Katip m) => Severity -> Text -> m ()
177+logM sev msg = logF sev () msg
159178