#if MIN_VERSION_base(4, 9, 0)
#endif
module Katip.Core where
import Control.Applicative as A
import Control.AutoUpdate
import Control.Concurrent
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Control
import Control.Monad.Trans.Either
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Resource
import Control.Monad.Trans.State
import Control.Monad.Trans.Writer
import Data.Aeson (FromJSON (..), ToJSON (..),
object)
import qualified Data.Aeson as A
import Data.Foldable as FT
import qualified Data.HashMap.Strict as HM
import Data.List
import qualified Data.Map.Strict as M
import Data.Semigroup
import Data.String
import Data.String.Conv
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as B
import Data.Time
import GHC.Generics hiding (to)
#if MIN_VERSION_base(4, 8, 0)
#if !MIN_VERSION_base(4, 9, 0)
import GHC.SrcLoc
#endif
import GHC.Stack
#endif
import Language.Haskell.TH
import qualified Language.Haskell.TH.Syntax as TH
import Lens.Micro
import Lens.Micro.TH
import Network.HostName
import System.Posix
readMay :: Read a => String -> Maybe a
readMay s = case [x | (x,t) <- reads s, ("","") <- lex t] of
[x] -> Just x
[] -> Nothing
_ -> Nothing
newtype Namespace = Namespace { unNamespace :: [Text] }
deriving (Eq,Show,Read,Ord,Generic,ToJSON,FromJSON,Semigroup,Monoid)
instance IsString Namespace where
fromString s = Namespace [fromString s]
intercalateNs :: Namespace -> [Text]
intercalateNs (Namespace xs) = intersperse "." xs
newtype Environment = Environment { getEnvironment :: Text }
deriving (Eq,Show,Read,Ord,Generic,ToJSON,FromJSON,IsString)
data Severity
= DebugS
| InfoS
| NoticeS
| WarningS
| ErrorS
| CriticalS
| AlertS
| EmergencyS
deriving (Eq, Ord, Show, Read, Generic, Enum, Bounded)
data Verbosity = V0 | V1 | V2 | V3
deriving (Eq, Ord, Show, Read, Generic, Enum)
renderSeverity :: Severity -> Text
renderSeverity s = case s of
DebugS -> "Debug"
InfoS -> "Info"
NoticeS -> "Notice"
WarningS -> "Warning"
ErrorS -> "Error"
CriticalS -> "Critical"
AlertS -> "Alert"
EmergencyS -> "Emergency"
textToSeverity :: Text -> Maybe Severity
textToSeverity "Debug" = Just DebugS
textToSeverity "Info" = Just InfoS
textToSeverity "Notice" = Just NoticeS
textToSeverity "Warning" = Just WarningS
textToSeverity "Error" = Just ErrorS
textToSeverity "Critical" = Just CriticalS
textToSeverity "Alert" = Just AlertS
textToSeverity "Emergency" = Just EmergencyS
textToSeverity _ = Nothing
instance ToJSON Severity where
toJSON s = A.String (renderSeverity s)
instance FromJSON Severity where
parseJSON = A.withText "Severity" parseSeverity
where
parseSeverity t = case textToSeverity t of
Just x -> return x
Nothing -> fail $ "Invalid Severity " ++ toS t
newtype LogStr = LogStr { unLogStr :: B.Builder }
deriving (Generic, Show)
instance IsString LogStr where
fromString = LogStr . B.fromString
instance Semigroup LogStr where
(LogStr a) <> (LogStr b) = LogStr (a <> b)
instance Monoid LogStr where
mappend = (<>)
mempty = LogStr mempty
instance FromJSON LogStr where
parseJSON = A.withText "LogStr" parseLogStr
where
parseLogStr = return . LogStr . B.fromText
logStr :: StringConv a Text => a -> LogStr
logStr t = LogStr (B.fromText $ toS t)
ls :: StringConv a Text => a -> LogStr
ls = logStr
showLS :: Show a => a -> LogStr
showLS = ls . show
newtype ThreadIdText = ThreadIdText {
getThreadIdText :: Text
} deriving (ToJSON, FromJSON, Show, Eq, Ord)
mkThreadIdText :: ThreadId -> ThreadIdText
mkThreadIdText = ThreadIdText . T.pack . show
data Item a = Item {
_itemApp :: Namespace
, _itemEnv :: Environment
, _itemSeverity :: Severity
, _itemThread :: ThreadIdText
, _itemHost :: HostName
, _itemProcess :: ProcessID
, _itemPayload :: a
, _itemMessage :: LogStr
, _itemTime :: UTCTime
, _itemNamespace :: Namespace
, _itemLoc :: Maybe Loc
} deriving (Generic, Functor)
makeLenses ''Item
instance Show a => Show (Item a) where
show Item{..} = "Item {_itemApp = " ++ show _itemApp ++ ", " ++
"_itemEnv = " ++ show _itemEnv ++ ", " ++
"_itemSeverity = " ++ show _itemSeverity ++ ", " ++
"_itemThread = " ++ show _itemThread ++ ", " ++
"_itemHost = " ++ show _itemHost ++ ", " ++
"_itemProcess = " ++ show _itemProcess ++ ", " ++
"_itemPayload = " ++ show _itemPayload ++ ", " ++
"_itemMessage = " ++ show _itemMessage ++ ", " ++
"_itemTime = " ++ show _itemTime ++ ", " ++
"_itemNamespace = " ++ show _itemNamespace ++ ", " ++
"_itemLoc = " ++ show (LocShow <$> _itemLoc) ++ "}"
newtype LocShow = LocShow Loc
instance Show LocShow where
show (LocShow Loc{..}) =
"Loc {loc_filename = " ++ show loc_filename ++ ", " ++
"loc_package = " ++ show loc_package ++ ", " ++
"loc_module = " ++ show loc_module ++ ", " ++
"loc_start = " ++ show loc_start ++ ", " ++
"loc_end = " ++ show loc_end ++ "}"
instance ToJSON a => ToJSON (Item a) where
toJSON Item{..} = A.object
[ "app" A..= _itemApp
, "env" A..= _itemEnv
, "sev" A..= _itemSeverity
, "thread" A..= getThreadIdText _itemThread
, "host" A..= _itemHost
, "pid" A..= ProcessIDJs _itemProcess
, "data" A..= _itemPayload
, "msg" A..= (B.toLazyText $ unLogStr _itemMessage)
, "at" A..= _itemTime
, "ns" A..= _itemNamespace
, "loc" A..= fmap LocJs _itemLoc
]
newtype LocJs = LocJs { getLocJs :: Loc }
instance ToJSON LocJs where
toJSON (LocJs (Loc fn p m (l, c) _)) = A.object
[ "loc_fn" A..= fn
, "loc_pkg" A..= p
, "loc_mod" A..= m
, "loc_ln" A..= l
, "loc_col" A..= c
]
instance FromJSON LocJs where
parseJSON = A.withObject "LocJs" parseLocJs
where
parseLocJs o = do
fn <- o A..: "loc_fn"
p <- o A..: "loc_pkg"
m <- o A..: "loc_mod"
l <- o A..: "loc_ln"
c <- o A..: "loc_col"
return $ LocJs $ Loc fn p m (l, c) (l, c)
instance FromJSON a => FromJSON (Item a) where
parseJSON = A.withObject "Item" parseItem
where
parseItem o = Item
<$> o A..: "app"
<*> o A..: "env"
<*> o A..: "sev"
<*> o A..: "thread"
<*> o A..: "host"
<*> (getProcessIDJs <$> o A..: "pid")
<*> o A..: "data"
<*> o A..: "msg"
<*> o A..: "at"
<*> o A..: "ns"
<*> (fmap getLocJs <$> o A..: "loc")
processIDToText :: ProcessID -> Text
processIDToText = toS . show
textToProcessID :: Text -> Maybe ProcessID
textToProcessID = readMay . toS
newtype ProcessIDJs = ProcessIDJs {
getProcessIDJs :: ProcessID
}
instance ToJSON ProcessIDJs where
toJSON (ProcessIDJs p) = A.String (processIDToText p)
instance FromJSON ProcessIDJs where
parseJSON = A.withText "ProcessID" parseProcessID
where
parseProcessID t = case textToProcessID t of
Just p -> return $ ProcessIDJs p
Nothing -> fail $ "Invalid ProcessIDJs " ++ toS t
data PayloadSelection
= AllKeys
| SomeKeys [Text]
deriving (Show, Eq)
instance Semigroup PayloadSelection where
AllKeys <> _ = AllKeys
_ <> AllKeys = AllKeys
SomeKeys as <> SomeKeys bs = SomeKeys (as <> bs)
instance Monoid PayloadSelection where
mempty = SomeKeys []
mappend = (<>)
class ToObject a where
toObject :: a -> A.Object
default toObject :: ToJSON a => a -> A.Object
toObject v = case toJSON v of
A.Object o -> o
_ -> mempty
instance ToObject ()
instance ToObject A.Object
class ToObject a => LogItem a where
payloadKeys :: Verbosity -> a -> PayloadSelection
instance LogItem () where payloadKeys _ _ = SomeKeys []
data AnyLogPayload = forall a. ToJSON a => AnyLogPayload a
newtype SimpleLogPayload = SimpleLogPayload {
unSimpleLogPayload :: [(Text, AnyLogPayload)]
}
instance ToJSON SimpleLogPayload where
toJSON (SimpleLogPayload as) = object $ map go as
where go (k, AnyLogPayload v) = k A..= v
instance ToObject SimpleLogPayload
instance LogItem SimpleLogPayload where
payloadKeys V0 _ = SomeKeys []
payloadKeys _ _ = AllKeys
instance Semigroup SimpleLogPayload where
SimpleLogPayload a <> SimpleLogPayload b = SimpleLogPayload (a <> b)
instance Monoid SimpleLogPayload where
mempty = SimpleLogPayload []
mappend = (<>)
sl :: ToJSON a => Text -> a -> SimpleLogPayload
sl a b = SimpleLogPayload [(a, AnyLogPayload b)]
payloadObject :: LogItem a => Verbosity -> a -> A.Object
payloadObject verb a = case FT.foldMap (flip payloadKeys a) [(V0)..verb] of
AllKeys -> toObject a
SomeKeys ks -> HM.filterWithKey (\ k _ -> k `FT.elem` ks) $ toObject a
itemJson :: LogItem a => Verbosity -> Item a -> A.Value
itemJson verb a = toJSON $ a & itemPayload %~ payloadObject verb
data Scribe = Scribe {
liPush :: forall a. LogItem a => Item a -> IO ()
}
instance Semigroup Scribe where
(Scribe a) <> (Scribe b) = Scribe $ \ item -> do
a item
b item
instance Monoid Scribe where
mempty = Scribe $ const $ return ()
mappend = (<>)
permitItem :: Severity -> Item a -> Bool
permitItem sev i = _itemSeverity i >= sev
data LogEnv = LogEnv {
_logEnvHost :: HostName
, _logEnvPid :: ProcessID
, _logEnvApp :: Namespace
, _logEnvEnv :: Environment
, _logEnvTimer :: IO UTCTime
, _logEnvScribes :: M.Map Text Scribe
}
makeLenses ''LogEnv
initLogEnv
:: Namespace
-> Environment
-> IO LogEnv
initLogEnv an env = LogEnv
<$> getHostName
<*> getProcessID
<*> pure an
<*> pure env
<*> mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime }
<*> pure mempty
registerScribe
:: Text
-> Scribe
-> LogEnv
-> LogEnv
registerScribe nm h = logEnvScribes %~ M.insert nm h
unregisterScribe
:: Text
-> LogEnv
-> LogEnv
unregisterScribe nm = logEnvScribes %~ M.delete nm
clearScribes
:: LogEnv
-> LogEnv
clearScribes = logEnvScribes .~ mempty
class MonadIO m => Katip m where
getLogEnv :: m LogEnv
instance Katip m => Katip (ReaderT s m) where
getLogEnv = lift getLogEnv
instance Katip m => Katip (EitherT s m) where
getLogEnv = lift getLogEnv
instance Katip m => Katip (ExceptT s m) where
getLogEnv = lift getLogEnv
instance Katip m => Katip (MaybeT m) where
getLogEnv = lift getLogEnv
instance Katip m => Katip (StateT s m) where
getLogEnv = lift getLogEnv
instance (Katip m, Monoid s) => Katip (WriterT s m) where
getLogEnv = lift getLogEnv
instance (Katip m) => Katip (ResourceT m) where
getLogEnv = lift getLogEnv
newtype KatipT m a = KatipT { unKatipT :: ReaderT LogEnv m a }
deriving ( Functor, Applicative, Monad, MonadIO
, MonadMask, MonadCatch, MonadThrow, MonadTrans, MonadBase b)
instance MonadIO m => Katip (KatipT m) where
getLogEnv = KatipT ask
instance MonadTransControl KatipT where
type StT (KatipT) a = a
liftWith f = KatipT $ ReaderT $ \le -> f $ \t -> runKatipT le t
restoreT = KatipT . ReaderT . const
instance (MonadBaseControl b m) => MonadBaseControl b (KatipT m) where
type StM ((KatipT) m) a = ComposeSt (KatipT) m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
runKatipT :: LogEnv -> KatipT m a -> m a
runKatipT le (KatipT f) = runReaderT f le
logItem
:: (A.Applicative m, LogItem a, Katip m)
=> a
-> Namespace
-> Maybe Loc
-> Severity
-> LogStr
-> m ()
logItem a ns loc sev msg = do
LogEnv{..} <- getLogEnv
liftIO $ do
item <- Item
<$> pure _logEnvApp
<*> pure _logEnvEnv
<*> pure sev
<*> (mkThreadIdText <$> myThreadId)
<*> pure _logEnvHost
<*> pure _logEnvPid
<*> pure a
<*> pure msg
<*> _logEnvTimer
<*> pure (_logEnvApp <> ns)
<*> pure loc
FT.forM_ (M.elems _logEnvScribes) $ \ (Scribe h) -> h item
logF
:: (Applicative m, LogItem a, Katip m)
=> a
-> Namespace
-> Severity
-> LogStr
-> m ()
logF a ns sev msg = logItem a ns Nothing sev msg
logException
:: (Katip m, LogItem a, MonadCatch m, Applicative m)
=> a
-> Namespace
-> Severity
-> m b
-> m b
logException a ns sev action = action `catchAll` \e -> f e >> throwM e
where
f e = logF a ns sev (msg e)
msg e = ls (T.pack "An exception has occured: ") <> showLS e
logMsg
:: (Applicative m, Katip m)
=> Namespace
-> Severity
-> LogStr
-> m ()
logMsg ns sev msg = logF () ns sev msg
instance TH.Lift Namespace where
lift (Namespace xs) =
let xs' = map T.unpack xs
in [| Namespace (map T.pack xs') |]
instance TH.Lift Verbosity where
lift V0 = [| V0 |]
lift V1 = [| V1 |]
lift V2 = [| V2 |]
lift V3 = [| V3 |]
instance TH.Lift Severity where
lift DebugS = [| DebugS |]
lift InfoS = [| InfoS |]
lift NoticeS = [| NoticeS |]
lift WarningS = [| WarningS |]
lift ErrorS = [| ErrorS |]
lift CriticalS = [| CriticalS |]
lift AlertS = [| AlertS |]
lift EmergencyS = [| EmergencyS |]
liftLoc :: Loc -> Q Exp
liftLoc (Loc a b c (d1, d2) (e1, e2)) = [|Loc
$(TH.lift a)
$(TH.lift b)
$(TH.lift c)
($(TH.lift d1), $(TH.lift d2))
($(TH.lift e1), $(TH.lift e2))
|]
#if MIN_VERSION_base(4, 8, 0)
getLoc :: (?loc :: CallStack) => Maybe Loc
getLoc = case getCallStack ?loc of
[] -> Nothing
xs -> Just . toLoc . last $ xs
where
toLoc :: (String, SrcLoc) -> Loc
toLoc (_, l) = Loc {
loc_filename = srcLocFile l
, loc_package = srcLocPackage l
, loc_module = srcLocModule l
, loc_start = (srcLocStartLine l, srcLocStartCol l)
, loc_end = (srcLocEndLine l, srcLocEndCol l)
}
#else
getLoc :: Maybe Loc
getLoc = Nothing
#endif
getLocTH :: ExpQ
getLocTH = [| $(location >>= liftLoc) |]
logT :: ExpQ
logT = [| \ a ns sev msg -> logItem a ns (Just $(getLocTH)) sev msg |]
logLoc :: (Applicative m, LogItem a, Katip m)
=> a
-> Namespace
-> Severity
-> LogStr
-> m ()
logLoc a ns = logItem a ns getLoc
locationToString :: Loc -> String
locationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++
' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc)
where
line = show . fst . loc_start
char = show . snd . loc_start