module Control.Effects.Logging (module Control.Effects.Logging) where
import Interlude
import Control.Effects as Control.Effects.Logging
import Control.Effects.Signal
import Data.Text hiding (length)
import Data.Time.ISO8601
import qualified Data.ByteString as BS
import GHC.Stack
import Data.Time (UTCTime, getCurrentTime)
data Logging = Logging
data instance Effect Logging method mr where
LoggingMsg :: Log -> Effect Logging 'Logging 'Msg
LoggingRes :: Effect Logging 'Logging 'Res
newtype Tag = Tag Text deriving (Eq, Ord, Read, Show)
newtype Context = Context { getContext :: Text } deriving (Eq, Ord, Read, Show)
data Level = Fatal | Error | Warning | Info | Debug deriving (Eq, Ord, Read, Show)
data LogUser = LogUser { logUserId :: Text
, logUserEmail :: Maybe Text
, logUserUsername :: Maybe Text }
deriving (Eq, Ord, Read, Show)
addIfExists :: Text -> Maybe Value -> [(Text, Value)] -> [(Text, Value)]
addIfExists _ Nothing ps = ps
addIfExists n (Just v) ps = (n, v) : ps
instance ToJSON LogUser where
toJSON LogUser{..} =
object $ ["id" .= logUserId]
& addIfExists "username" (String <$> logUserUsername)
& addIfExists "email" (String <$> logUserEmail)
data Crumb = Crumb { crumbTimestamp :: UTCTime
, crumbMessage :: Maybe Text
, crumbCategory :: Text
, crumbData :: CrumbData }
deriving (Eq, Read, Show)
data CrumbData = DefaultCrumb [(Text, Value)]
| HttpCrumb { crumbUrl :: Text
, crumbMethod :: Text
, crumbStatusCode :: Int
, crumbReason :: Text }
deriving (Eq, Read, Show)
instance ToJSON CrumbData where
toJSON (DefaultCrumb d) = object d
toJSON HttpCrumb{..} =
object [ "url" .= crumbUrl
, "method" .= crumbMethod
, "status_code" .= crumbStatusCode
, "reason" .= crumbReason ]
instance ToJSON Crumb where
toJSON Crumb{..} =
object $ [ "timestamp" .= formatISO8601 crumbTimestamp
, "category" .= crumbCategory
, "type" .= case crumbData of
DefaultCrumb _ -> "default" :: Text
HttpCrumb{} -> "http"
, "data" .= crumbData ]
& addIfExists "message" (String <$> crumbMessage)
data Log = Log { logMessage :: Text
, logLevel :: Level
, logTags :: [Tag]
, logContext :: [Context]
, logUser :: Maybe LogUser
, logCrumbs :: [Crumb]
, logData :: ByteString
, logTimestamp :: Maybe UTCTime
, logCallStack :: CallStack }
deriving (Show)
newtype GenericException = GenericException Text deriving (Eq, Ord, Read, Show)
instance Exception GenericException
logEffect :: MonadEffect Logging m => Log -> m ()
logEffect = void . effect . LoggingMsg
handleLogging :: Functor m => (Log -> m ()) -> EffectHandler Logging m a -> m a
handleLogging f = handleEffect (\(LoggingMsg l) -> LoggingRes <$ f l)
layerLogs :: MonadEffect Logging m => Context -> EffectHandler Logging m a -> m a
layerLogs ctx = handleLogging (\log' -> logEffect (log' { logContext = ctx : logContext log' }))
originContext :: Log -> Maybe Context
originContext Log{..} = listToMaybe (Interlude.reverse logContext)
logInfo, logWarning, logError :: (HasCallStack, MonadEffect Logging m) => Text -> m ()
logInfo msg = logEffect $ Log msg Info [] [] Nothing [] "" Nothing callStack
logWarning msg = logEffect $ Log msg Warning [] [] Nothing [] "" Nothing callStack
logError msg = logEffect $ Log msg Error [] [] Nothing [] "" Nothing callStack
logAndError :: (Exception e, MonadEffect Logging m, MonadThrow m, HasCallStack) => Text -> e -> m a
logAndError msg err = logError msg >> throwM err
logAndThrowsErr :: (MonadEffect Logging m, Throws e m, HasCallStack) => Text -> e -> m a
logAndThrowsErr msg err = logError msg >> throwSignal err
logAndThrowGeneric :: (MonadEffect Logging m, MonadThrow m, HasCallStack) => Text -> m a
logAndThrowGeneric msg = logError msg >> throwM (GenericException msg)
logMessagesToStdout :: MonadIO m => EffectHandler Logging m a -> m a
logMessagesToStdout = handleLogging (\Log{..} -> putText (pshow logLevel <> ": " <> logMessage))
logRawToStdout :: MonadIO m => EffectHandler Logging m a -> m a
logRawToStdout = handleLogging print
muteLogs :: Monad m => EffectHandler Logging m a -> m a
muteLogs = handleLogging (const (return ()))
witherLogs :: MonadEffect Logging m => (Log -> m (Maybe Log)) -> EffectHandler Logging m a -> m a
witherLogs f = handleLogging $ f >=> maybe (return ()) logEffect
filterLogs :: MonadEffect Logging m => (Log -> Bool) -> EffectHandler Logging m a -> m a
filterLogs f = witherLogs (\l -> return $ if f l then Just l else Nothing)
mapLogs :: MonadEffect Logging m => (Log -> m Log) -> EffectHandler Logging m a -> m a
mapLogs f = witherLogs ((Just <$>) . f)
logIfDepthLessThan :: MonadEffect Logging m => Int -> EffectHandler Logging m a -> m a
logIfDepthLessThan n = logIfDepth (< n)
logIfDepth :: MonadEffect Logging m => (Int -> Bool) -> EffectHandler Logging m a -> m a
logIfDepth cond = filterLogs (\Log{..} -> cond (length logContext))
messagesToCrumbs :: (MonadIO m, MonadEffect Logging m) => EffectHandler Logging m a -> m a
messagesToCrumbs = mapLogs $ \l@Log{..} -> do
time <- liftIO getCurrentTime
let cat = Data.Text.intercalate "." (fmap getContext logContext)
return (l { logCrumbs = logCrumbs ++ [Crumb time (Just logMessage) cat (DefaultCrumb [])] })
collectCrumbs :: MonadEffect Logging m => EffectHandler Logging (StateT [Crumb] m) a -> m a
collectCrumbs = flip evalStateT [] . mapLogs (\l@Log{..} -> do
crumbs <- get
let newCrumbs = crumbs ++ logCrumbs
put newCrumbs
return (l { logCrumbs = newCrumbs }))
addUserToLogs :: MonadEffect Logging m => LogUser -> EffectHandler Logging m a -> m a
addUserToLogs user = mapLogs (\l -> return (l { logUser = Just user }))
addCrumbToLogs :: MonadEffect Logging m => Crumb -> EffectHandler Logging m a -> m a
addCrumbToLogs crumb = mapLogs (\l -> return (l { logCrumbs = logCrumbs l ++ [crumb] }))
setDataTo :: MonadEffect Logging m => ByteString -> EffectHandler Logging m a -> m a
setDataTo bs = mapLogs (\l -> return (l { logData = bs }))
setDataToJsonOf :: (MonadEffect Logging m, ToJSON v) => v -> EffectHandler Logging m a -> m a
setDataToJsonOf = setDataTo . toS . encode
setDataToShowOf :: (MonadEffect Logging m, Show v) => v -> EffectHandler Logging m a -> m a
setDataToShowOf = setDataTo . pshow
setTimestampToNow :: (MonadEffect Logging m, MonadIO m) => EffectHandler Logging m a -> m a
setTimestampToNow = mapLogs $ \l -> do
time <- liftIO getCurrentTime
return (l { logTimestamp = Just time })
prettyPrintSummary :: MonadIO m => Int -> EffectHandler Logging m a -> m a
prettyPrintSummary trunc h = do
lock <- liftIO (newMVar ())
flip handleLogging h $ \Log{..} -> liftIO $ withMVar lock $ \_ -> do
putText "┌"
putText ("| " <> pshow logLevel <> " Log")
putText ("| Message: " <> logMessage)
putText ("| Time: " <> pshow logTimestamp)
putText ("| Data: " <> toS (BS.take trunc logData) <> "...")
when (isJust logUser) $ do
let Just LogUser{..} = logUser
putText ("| User: " <> logUserId <> ", "
<> fromMaybe " - " logUserEmail <> ", "
<> fromMaybe " - " logUserUsername)
putText ("| Stack: " <> toS (BS.take trunc (pshow logCallStack)) <> "...")
putText "└"