@@ -0,0 +1,160 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE RankNTypes #-}
7+{-# LANGUAGE RecordWildCards #-}
8+{-# LANGUAGE TemplateHaskell #-}
9+
10+module Soothsayer.Core where
11+
12+-------------------------------------------------------------------------------
13+import Control.Applicative
14+import Control.AutoUpdate
15+import Control.Concurrent
16+import Control.Lens
17+import Control.Monad.Reader
18+
19+import Data.Aeson (ToJSON)
20+import qualified Data.Aeson as A
21+import qualified Data.Map.Strict as M
22+import Data.Monoid
23+import Data.Text (Text)
24+import Data.Time
25+import GHC.Generics hiding (to)
26+import Network.HostName
27+-------------------------------------------------------------------------------
28+
29+
30+newtype AppName = AppName { getAppName :: Text }
31+ deriving (Eq,Show,Read,Ord,Generic,ToJSON)
32+
33+newtype Environment = Environment { getEnvironment :: Text }
34+ deriving (Eq,Show,Read,Ord,Generic,ToJSON)
35+
36+
37+-------------------------------------------------------------------------------
38+data Severity
39+ = Debug -- ^ Debug messages
40+ | Info -- ^ Information
41+ | Notice -- ^ Normal runtime Conditions
42+ | Warning -- ^ General Warnings
43+ | Error -- ^ General Errors
44+ | Critical -- ^ Severe situations
45+ | Alert -- ^ Take immediate action
46+ | Emergency -- ^ System is unusable
47+ deriving (Eq, Ord, Show, Read, Generic)
48+
49+
50+-------------------------------------------------------------------------------
51+renderSeverity :: Severity -> Text
52+renderSeverity s = case s of
53+ Debug -> "Debug"
54+ Info -> "Debug"
55+ Notice -> "Notice"
56+ Warning -> "Warning"
57+ Error -> "Error"
58+ Critical -> "Critical"
59+ Alert -> "Alert"
60+ Emergency -> "Emergency"
61+
62+
63+-------------------------------------------------------------------------------
64+instance ToJSON Severity where
65+ toJSON s = A.String (renderSeverity s)
66+
67+-------------------------------------------------------------------------------
68+data Item a = Item {
69+ itemApp :: AppName
70+ , itemEnv :: Environment
71+ , itemSeverity :: Severity
72+ , itemThread :: ThreadId
73+ , itemHost :: HostName
74+ , itemPayload :: a
75+ , itemMessage :: Text
76+ , itemTime :: UTCTime
77+ } deriving (Show,Generic)
78+
79+
80+
81+instance ToJSON a => ToJSON (Item a) where
82+ toJSON Item{..} = A.object
83+ [ "app" A..= itemApp
84+ , "env" A..= itemEnv
85+ , "sev" A..= itemSeverity
86+ , "thread" A..= show itemThread
87+ , "host" A..= itemHost
88+ , "data" A..= itemPayload
89+ , "msg" A..= itemMessage
90+ , "at" A..= itemTime
91+ ]
92+
93+
94+-------------------------------------------------------------------------------
95+data LogHandler = LogHandler {
96+ lhPush :: forall a. ToJSON a => Item a -> IO ()
97+ }
98+
99+
100+-------------------------------------------------------------------------------
101+data LogEnv = LogEnv {
102+ _logEnvHost :: HostName
103+ , _logEnvApp :: AppName
104+ , _logEnvEnv :: Environment
105+ , _logEnvTimer :: IO UTCTime
106+ , _logEnvHandlers :: M.Map Text LogHandler
107+ }
108+makeLenses ''LogEnv
109+
110+
111+-------------------------------------------------------------------------------
112+initLogEnv :: AppName -> Environment -> IO LogEnv
113+initLogEnv an env = LogEnv
114+ <$> getHostName
115+ <*> pure an
116+ <*> pure env
117+ <*> mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime }
118+ <*> pure mempty
119+
120+
121+-------------------------------------------------------------------------------
122+registerHandler
123+ :: Text
124+ -- ^ Name the handler
125+ -> LogHandler
126+ -> LogEnv
127+ -> LogEnv
128+registerHandler nm h = logEnvHandlers . at nm .~ Just h
129+
130+
131+-------------------------------------------------------------------------------
132+unregisterHandler
133+ :: Text
134+ -- ^ Name of the handler
135+ -> LogEnv
136+ -> LogEnv
137+unregisterHandler nm = logEnvHandlers . at nm .~ Nothing
138+
139+
140+-------------------------------------------------------------------------------
141+logM
142+ :: (Applicative m, MonadIO m, ToJSON a, MonadReader LogEnv m)
143+ => Severity
144+ -> a
145+ -> Text
146+ -> m ()
147+logM sev a msg = do
148+ item <- Item
149+ <$> view logEnvApp
150+ <*> view logEnvEnv
151+ <*> pure sev
152+ <*> liftIO myThreadId
153+ <*> view logEnvHost
154+ <*> pure a
155+ <*> pure msg
156+ <*> (view logEnvTimer >>= liftIO)
157+ hs <- view $ logEnvHandlers . to M.elems
158+ liftIO $ forM_ hs $ \ (LogHandler h) -> h item
159+
160+