module Control.Effects.Logging (module Control.Effects.Logging) where
import Interlude hiding (truncate)
import Control.Effects as Control.Effects.Logging
import Control.Effects.Signal
import qualified Data.Text as Text
import Data.Time.ISO8601
import GHC.Stack
import Data.Time (UTCTime, getCurrentTime)
import Language.Haskell.HsColour.ANSI
import System.Directory
import System.FilePath
import Data.UUID.V4
import Data.String
import Control.Effects.Early
import Data.UUID
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 = Debug | Info | Warning | Error | Fatal 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 LogData = LogData { dataPayload :: ByteString
, dataSummary :: Text }
deriving (Eq, Ord, Read, Show)
instance IsString LogData where
fromString s = LogData (toS s) ""
data Log = Log { logMessage :: Text
, logLevel :: Level
, logTags :: [Tag]
, logContext :: [Context]
, logUser :: Maybe LogUser
, logCrumbs :: [Crumb]
, logData :: LogData
, 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 :: (HasCallStack, 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)
logWithLevel :: (HasCallStack, MonadEffect Logging m) => Level -> Text -> m ()
logWithLevel lvl msg = logEffect $ Log msg lvl [] [] Nothing [] "" Nothing callStack
logInfo, logWarning, logError, logDebug, logFatal
:: (HasCallStack, MonadEffect Logging m) => Text -> m ()
logInfo = logWithLevel Info
logWarning = logWithLevel Warning
logError = logWithLevel Error
logDebug = logWithLevel Debug
logFatal = logWithLevel Fatal
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 = 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] }))
setDataWithSummary :: MonadEffect Logging m => LogData -> EffectHandler Logging m a -> m a
setDataWithSummary dat = mapLogs (\l -> return (l { logData = dat }))
setDataTo :: MonadEffect Logging m => ByteString -> EffectHandler Logging m a -> m a
setDataTo bs = setDataWithSummary (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 })
highlightT :: [Highlight] -> Text -> Text
highlightT hs = toS . highlight hs . toS
yellow :: Text -> Text
yellow = highlightT [Foreground Yellow]
colorFromLevel :: Level -> [Highlight]
colorFromLevel Debug = [Foreground Cyan]
colorFromLevel Info = [Foreground White]
colorFromLevel Warning = [Foreground Yellow]
colorFromLevel Error = [Foreground Red]
colorFromLevel Fatal = [Foreground Black, Background Red]
writeDataToFiles ::
( MonadEffect Logging m, MonadIO m )
=> FilePath -> EffectHandler Logging m a -> m a
writeDataToFiles path m = do
liftIO (createDirectoryIfMissing True path)
m & mapLogs ( \l@Log{..} -> do
uuid <- liftIO nextRandom
let fp = path </> toString uuid <.> "txt"
let LogData{..} = logData
liftIO $
writeFile fp
(toS dataSummary <> "\n"
<> toSL dataPayload <> "\n"
<> pshow logCrumbs <> "\n"
<> prettyCallStack logCallStack)
return (l { logData = LogData "" (toS fp) }) )
truncate :: Int -> Text -> Text
truncate at txt = if Text.length txt > at then Text.take (at 4) txt <> " ..." else txt
manyLines :: Int -> Text -> Text
manyLines trunc =
Text.lines
>>> fmap (truncate trunc)
>>> zip [0 :: Int ..]
>>> fmap (\(i, l) -> if i == 0 then l else "│ " <> l)
>>> Text.intercalate "\n"
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
let callStackSection = manyLines trunc (toS (prettyCallStack logCallStack))
let LogData{..} = logData
let dataSection =
if dataSummary == "" then truncate trunc (toSL dataPayload)
else manyLines trunc dataSummary
putText "┌"
putText ("│ " <> highlightT (colorFromLevel logLevel) (pshow logLevel <> " Log"))
putText ("│ " <> yellow "Message: " <> logMessage)
handleEarly $ do
ts <- ifNothingEarlyReturn () logTimestamp
putText ("│ " <> yellow "Time: " <> pshow ts)
unless (Text.null dataSection) $
putText ("│ " <> yellow "Data: " <> dataSection)
when (isJust logUser) $ do
let Just LogUser{..} = logUser
putText ("│ " <> yellow "User: " <> logUserId <> ", "
<> fromMaybe " - " logUserEmail <> ", "
<> fromMaybe " - " logUserUsername)
putText ("│ " <> yellow "Stack: " <> callStackSection)
putText "└"
logIOExceptions :: (MonadEffect Logging m, MonadCatch m) => m a -> m a
logIOExceptions = handleAll $ \(SomeException e) -> do
logError "An IO exception occurred"
& setDataWithSummary (LogData (pshow e) (toS (displayException e)))
throwM e