git.iko.soy/typeable/katip
on master help sign in
Flesh out a bit more
134d780Ozgun Ataman
katip.cabal+9−8
compare with master
unifiedsplit
@@ -17,17 +17,18 @@ cabal-version: >=1.10
17library
17library
18 exposed-modules:
18 exposed-modules:
19 Katip.Core
19 Katip.Core
20− Katip.Backends.Handle
20+ Katip.Scribes.Handle
21
21
22 -- other-modules:
22 -- other-modules:
23− other-extensions:
23+ default-extensions:
24− DeriveGeneric,
24+ DeriveGeneric
25− FlexibleContexts,
25+ FlexibleContexts
26− GeneralizedNewtypeDeriving,
26+ GeneralizedNewtypeDeriving
27− MultiParamTypeClasses,
27+ MultiParamTypeClasses
28− RankNTypes,
28+ RankNTypes
29− RecordWildCards,
29+ RecordWildCards
30 TemplateHaskell
30 TemplateHaskell
31+ OverloadedStrings
31
32
32 build-depends:
33 build-depends:
33 base >=4.6 && <4.7
34 base >=4.6 && <4.7
src/Katip/Core.hs+33−14
@@ -19,6 +19,7 @@ import Data.Aeson (ToJSON)
19import qualified Data.Aeson as A
19import qualified Data.Aeson as A
20import qualified Data.Map.Strict as M
20import qualified Data.Map.Strict as M
21import Data.Monoid
21import Data.Monoid
22+import Data.String
22import Data.Text (Text)
23import Data.Text (Text)
23import Data.Time
24import Data.Time
24import GHC.Generics hiding (to)
25import GHC.Generics hiding (to)
@@ -27,10 +28,10 @@ import Network.HostName
27
28
28
29
29newtype AppName = AppName { getAppName :: Text }
30newtype AppName = AppName { getAppName :: Text }
30− deriving (Eq,Show,Read,Ord,Generic,ToJSON)
31+ deriving (Eq,Show,Read,Ord,Generic,ToJSON,IsString)
31
32
32newtype Environment = Environment { getEnvironment :: Text }
33newtype Environment = Environment { getEnvironment :: Text }
33− deriving (Eq,Show,Read,Ord,Generic,ToJSON)
34+ deriving (Eq,Show,Read,Ord,Generic,ToJSON,IsString)
34
35
35
36
36-------------------------------------------------------------------------------
37-------------------------------------------------------------------------------
@@ -63,7 +64,9 @@ renderSeverity s = case s of
63instance ToJSON Severity where
64instance ToJSON Severity where
64 toJSON s = A.String (renderSeverity s)
65 toJSON s = A.String (renderSeverity s)
65
66
67+
66-------------------------------------------------------------------------------
68-------------------------------------------------------------------------------
69+-- | This has everything each log message will contain.
67data Item a = Item {
70data Item a = Item {
68 itemApp :: AppName
71 itemApp :: AppName
69 , itemEnv :: Environment
72 , itemEnv :: Environment
@@ -91,7 +94,9 @@ instance ToJSON a => ToJSON (Item a) where
91
94
92
95
93-------------------------------------------------------------------------------
96-------------------------------------------------------------------------------
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 {
95 lhPush :: forall a. ToJSON a => Item a -> IO ()
100 lhPush :: forall a. ToJSON a => Item a -> IO ()
96 }
101 }
97
102
@@ -102,7 +107,7 @@ data LogEnv = LogEnv {
102 , _logEnvApp :: AppName
107 , _logEnvApp :: AppName
103 , _logEnvEnv :: Environment
108 , _logEnvEnv :: Environment
104 , _logEnvTimer :: IO UTCTime
109 , _logEnvTimer :: IO UTCTime
105− , _logEnvHandlers :: M.Map Text LogHandler
110+ , _logEnvHandlers :: M.Map Text Scribe
106 }
111 }
107makeLenses ''LogEnv
112makeLenses ''LogEnv
108
113
@@ -121,7 +126,7 @@ initLogEnv an env = LogEnv
121registerHandler
126registerHandler
122 :: Text
127 :: Text
123 -- ^ Name the handler
128 -- ^ Name the handler
124− -> LogHandler
129+ -> Scribe
125 -> LogEnv
130 -> LogEnv
126 -> LogEnv
131 -> LogEnv
127registerHandler nm h = logEnvHandlers . at nm .~ Just h
132registerHandler nm h = logEnvHandlers . at nm .~ Just h
@@ -136,24 +141,38 @@ unregisterHandler
136unregisterHandler nm = logEnvHandlers . at nm .~ Nothing
141unregisterHandler nm = logEnvHandlers . at nm .~ Nothing
137
142
138
143
144+
145+class Katip m where
146+ getLogEnv :: m LogEnv
147+
148+
149+
139-------------------------------------------------------------------------------
150-------------------------------------------------------------------------------
140−logM
151+-- | The generic *full* logging function.
152+logF
141− :: (Applicative m, MonadIO m, ToJSON a, MonadReader LogEnv m)
153+ :: (Applicative m, MonadIO m, ToJSON a, Katip m)
142 => Severity
154 => Severity
143 -> a
155 -> a
156+ -- ^ Contextual payload for the log
144 -> Text
157 -> Text
158+ -- ^ The log message
145 -> m ()
159 -> m ()
146−logM sev a msg = do
160+logF sev a msg = do
161+ LogEnv{..} <- getLogEnv
147 item <- Item
162 item <- Item
148− <$> view logEnvApp
163+ <$> pure _logEnvApp
149− <*> view logEnvEnv
164+ <*> pure _logEnvEnv
150 <*> pure sev
165 <*> pure sev
151 <*> liftIO myThreadId
166 <*> liftIO myThreadId
152− <*> view logEnvHost
167+ <*> pure _logEnvHost
153 <*> pure a
168 <*> pure a
154 <*> pure msg
169 <*> pure msg
155− <*> (view logEnvTimer >>= liftIO)
170+ <*> liftIO _logEnvTimer
156− hs <- view $ logEnvHandlers . to M.elems
171+ liftIO $ forM_ (M.elems _logEnvHandlers) $ \ (Scribe h) -> h item
157− liftIO $ forM_ hs $ \ (LogHandler h) -> h item
172+
158
173
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
159
178
src/Katip/Backends/Handle.hs → src/Katip/Scribes/Handle.hsrenamed+28−5
@@ -1,5 +1,8 @@
1{-# LANGUAGE RecordWildCards #-}
1{-# LANGUAGE RecordWildCards #-}
2+
2−module Katip.Backends.Handle where
3+module Katip.Scribes.Handle
4+ ( mkHandleScribe
5+ ) where
3
6
4-------------------------------------------------------------------------------
7-------------------------------------------------------------------------------
5import Blaze.ByteString.Builder
8import Blaze.ByteString.Builder
@@ -13,6 +16,7 @@ import Data.Monoid
13import Data.Text (Text)
16import Data.Text (Text)
14import Data.Time
17import Data.Time
15import System.IO
18import System.IO
19+import System.IO.Unsafe (unsafePerformIO)
16import System.Locale
20import System.Locale
17-------------------------------------------------------------------------------
21-------------------------------------------------------------------------------
18import Katip.Core
22import Katip.Core
@@ -40,10 +44,10 @@ renderPrim NullPrim = fromByteString "null"
40
44
41
45
42-------------------------------------------------------------------------------
46-------------------------------------------------------------------------------
43−mkHandleHandler :: Handle -> [Text] -> IO LogHandler
47+mkHandleScribe :: Handle -> [Text] -> Severity -> IO Scribe
44−mkHandleHandler h keys = do
48+mkHandleScribe h keys sev = do
45 hSetBuffering h LineBuffering
49 hSetBuffering h LineBuffering
46− return $ LogHandler $ \ Item{..} -> do
50+ return $ Scribe $ \ Item{..} -> do
47 let nowStr = fromString $ formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" itemTime
51 let nowStr = fromString $ formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" itemTime
48 ks = map brackets $ getKeys itemPayload keys
52 ks = map brackets $ getKeys itemPayload keys
49 msg = brackets nowStr <>
53 msg = brackets nowStr <>
@@ -52,5 +56,24 @@ mkHandleHandler h keys = do
52 brackets (fromString (show itemThread)) <>
56 brackets (fromString (show itemThread)) <>
53 mconcat ks <>
57 mconcat ks <>
54 fromText " " <> fromText itemMessage
58 fromText " " <> fromText itemMessage
59+ if itemSeverity >= sev
55− B.putStrLn $ toByteString msg
60+ then B.putStrLn $ toByteString msg
61+ else return ()
62+
63+
64+
65+-------------------------------------------------------------------------------
66+-- | An implicit environment to enable logging directly ouf of the IO monad.
67+_ioLogEnv :: LogEnv
68+_ioLogEnv = unsafePerformIO $ do
69+ le <- initLogEnv "io" "io"
70+ lh <- mkHandleScribe stdout [] Debug
71+ return $ registerHandler "stdout" lh le
72+{-# NOINLINE _ioLogEnv #-}
73+
74+
75+-------------------------------------------------------------------------------
76+-- | A default IO instance to make prototype development easy. User
77+-- your own 'Monad' for production.
78+instance Katip IO where getLogEnv = return _ioLogEnv
56
79