{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
module RIO.Prelude.Logger
(
logDebug
, logInfo
, logWarn
, logError
, logOther
, withLogFunc
, newLogFunc
, LogFunc
, HasLogFunc (..)
, logOptionsHandle
, LogOptions
, setLogMinLevel
, setLogMinLevelIO
, setLogVerboseFormat
, setLogVerboseFormatIO
, setLogTerminal
, setLogUseTime
, setLogUseColor
, setLogUseLoc
, logSticky
, logStickyDone
, logDebugS
, logInfoS
, logWarnS
, logErrorS
, logOtherS
, logGeneric
, mkLogFunc
, logOptionsMemory
, LogLevel (..)
, LogSource
, CallStack
, displayCallStack
, noLogging
, logFuncUseColorL
) where
import RIO.Prelude.Reexports hiding ((<>))
import RIO.Prelude.Renames
import RIO.Prelude.Display
import RIO.Prelude.Lens
import Data.Text (Text)
import qualified Data.Text as T
import Control.Monad.IO.Class (MonadIO, liftIO)
import GHC.Stack (HasCallStack, CallStack, SrcLoc (..), getCallStack, callStack)
import Data.Time
import qualified Data.Text.IO as TIO
import Data.ByteString.Builder (toLazyByteString, char7, byteString, hPutBuilder)
import Data.ByteString.Builder.Extra (flush)
import GHC.IO.Handle.Internals (wantWritableHandle)
import GHC.IO.Encoding.Types (textEncodingName)
import GHC.IO.Handle.Types (Handle__ (..))
import qualified Data.ByteString as B
import System.IO (localeEncoding)
import GHC.Foreign (peekCString, withCString)
import Data.Semigroup (Semigroup (..))
data LogLevel = LevelDebug | LevelInfo | LevelWarn | LevelError | LevelOther !Text
deriving (Eq, Show, Read, Ord)
type LogSource = Text
class HasLogFunc env where
logFuncL :: Lens' env LogFunc
instance HasLogFunc LogFunc where
logFuncL = id
data LogFunc = LogFunc
{ unLogFunc :: !(CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
, lfOptions :: !(Maybe LogOptions)
}
instance Semigroup LogFunc where
LogFunc f o1 <> LogFunc g o2 = LogFunc
{ unLogFunc = \a b c d -> f a b c d *> g a b c d
, lfOptions = o1 `mplus` o2
}
instance Monoid LogFunc where
mempty = mkLogFunc $ \_ _ _ _ -> return ()
mappend = (<>)
mkLogFunc :: (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()) -> LogFunc
mkLogFunc f = LogFunc f Nothing
logGeneric
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> LogSource
-> LogLevel
-> Utf8Builder
-> m ()
logGeneric src level str = do
LogFunc logFunc _ <- view logFuncL
liftIO $ logFunc callStack src level str
logDebug
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> Utf8Builder
-> m ()
logDebug = logGeneric "" LevelDebug
logInfo
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> Utf8Builder
-> m ()
logInfo = logGeneric "" LevelInfo
logWarn
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> Utf8Builder
-> m ()
logWarn = logGeneric "" LevelWarn
logError
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> Utf8Builder
-> m ()
logError = logGeneric "" LevelError
logOther
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> Text
-> Utf8Builder
-> m ()
logOther = logGeneric "" . LevelOther
logDebugS
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> LogSource
-> Utf8Builder
-> m ()
logDebugS src = logGeneric src LevelDebug
logInfoS
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> LogSource
-> Utf8Builder
-> m ()
logInfoS src = logGeneric src LevelInfo
logWarnS
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> LogSource
-> Utf8Builder
-> m ()
logWarnS src = logGeneric src LevelWarn
logErrorS
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> LogSource
-> Utf8Builder
-> m ()
logErrorS src = logGeneric src LevelError
logOtherS
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> Text
-> LogSource
-> Utf8Builder
-> m ()
logOtherS src = logGeneric src . LevelOther
logSticky :: (MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) => Utf8Builder -> m ()
logSticky = logOther "sticky"
logStickyDone :: (MonadIO m, HasCallStack, MonadReader env m, HasLogFunc env) => Utf8Builder -> m ()
logStickyDone = logOther "sticky-done"
canUseUtf8 :: MonadIO m => Handle -> m Bool
canUseUtf8 h = liftIO $ wantWritableHandle "canUseUtf8" h $ \h_ -> do
return $ (textEncodingName <$> haCodec h_) == Just "UTF-8"
logOptionsMemory :: MonadIO m => m (IORef Builder, LogOptions)
logOptionsMemory = do
ref <- newIORef mempty
let options = LogOptions
{ logMinLevel = return LevelInfo
, logVerboseFormat = return False
, logTerminal = True
, logUseTime = False
, logUseColor = False
, logUseLoc = False
, logSend = \new -> atomicModifyIORef' ref $ \old -> (old <> new, ())
}
return (ref, options)
logOptionsHandle
:: MonadIO m
=> Handle
-> Bool
-> m LogOptions
logOptionsHandle handle' verbose = liftIO $ do
terminal <- hIsTerminalDevice handle'
useUtf8 <- canUseUtf8 handle'
unicode <- if useUtf8 then return True else getCanUseUnicode
return LogOptions
{ logMinLevel = return $ if verbose then LevelDebug else LevelInfo
, logVerboseFormat = return verbose
, logTerminal = terminal
, logUseTime = verbose
, logUseColor = verbose && terminal
, logUseLoc = verbose
, logSend = \builder ->
if useUtf8 && unicode
then hPutBuilder handle' (builder <> flush)
else do
let lbs = toLazyByteString builder
bs = toStrictBytes lbs
case decodeUtf8' bs of
Left e -> error $ "mkLogOptions: invalid UTF8 sequence: " ++ show (e, bs)
Right text -> do
let text'
| unicode = text
| otherwise = T.map replaceUnicode text
TIO.hPutStr handle' text'
hFlush handle'
}
getCanUseUnicode :: IO Bool
getCanUseUnicode = do
let enc = localeEncoding
str = "\x2018\x2019"
test = withCString enc str $ \cstr -> do
str' <- peekCString enc cstr
return (str == str')
test `catchIO` \_ -> return False
newLogFunc :: (MonadIO n, MonadIO m) => LogOptions -> n (LogFunc, m ())
newLogFunc options =
if logTerminal options then do
var <- newMVar mempty
return (LogFunc
{ unLogFunc = stickyImpl var options (simpleLogFunc options)
, lfOptions = Just options
}
, do state <- takeMVar var
unless (B.null state) (liftIO $ logSend options "\n")
)
else
return (LogFunc
{ unLogFunc = \cs src level str ->
simpleLogFunc options cs src (noSticky level) str
, lfOptions = Just options
}
, return ()
)
withLogFunc :: MonadUnliftIO m => LogOptions -> (LogFunc -> m a) -> m a
withLogFunc options inner = withRunInIO $ \run -> do
bracket (newLogFunc options)
snd
(run . inner . fst)
replaceUnicode :: Char -> Char
replaceUnicode '\x2018' = '`'
replaceUnicode '\x2019' = '\''
replaceUnicode c = c
noSticky :: LogLevel -> LogLevel
noSticky (LevelOther "sticky-done") = LevelInfo
noSticky (LevelOther "sticky") = LevelInfo
noSticky level = level
data LogOptions = LogOptions
{ logMinLevel :: !(IO LogLevel)
, logVerboseFormat :: !(IO Bool)
, logTerminal :: !Bool
, logUseTime :: !Bool
, logUseColor :: !Bool
, logUseLoc :: !Bool
, logSend :: !(Builder -> IO ())
}
setLogMinLevel :: LogLevel -> LogOptions -> LogOptions
setLogMinLevel level options = options { logMinLevel = return level }
setLogMinLevelIO :: IO LogLevel -> LogOptions -> LogOptions
setLogMinLevelIO getLevel options = options { logMinLevel = getLevel }
setLogVerboseFormat :: Bool -> LogOptions -> LogOptions
setLogVerboseFormat v options = options { logVerboseFormat = return v }
setLogVerboseFormatIO :: IO Bool -> LogOptions -> LogOptions
setLogVerboseFormatIO getVerboseLevel options =
options { logVerboseFormat = getVerboseLevel }
setLogTerminal :: Bool -> LogOptions -> LogOptions
setLogTerminal t options = options { logTerminal = t }
setLogUseTime :: Bool -> LogOptions -> LogOptions
setLogUseTime t options = options { logUseTime = t }
setLogUseColor :: Bool -> LogOptions -> LogOptions
setLogUseColor c options = options { logUseColor = c }
setLogUseLoc :: Bool -> LogOptions -> LogOptions
setLogUseLoc l options = options { logUseLoc = l }
simpleLogFunc :: LogOptions -> CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
simpleLogFunc lo cs _src level msg = do
logLevel <- logMinLevel lo
logVerbose <- logVerboseFormat lo
when (level >= logLevel) $ do
timestamp <- getTimestamp logVerbose
logSend lo $ getUtf8Builder $
timestamp <>
getLevel logVerbose <>
ansi reset <>
msg <>
getLoc <>
ansi reset <>
"\n"
where
reset = "\ESC[0m"
setBlack = "\ESC[90m"
setGreen = "\ESC[32m"
setBlue = "\ESC[34m"
setYellow = "\ESC[33m"
setRed = "\ESC[31m"
setMagenta = "\ESC[35m"
ansi :: Utf8Builder -> Utf8Builder
ansi xs | logUseColor lo = xs
| otherwise = mempty
getTimestamp :: Bool -> IO Utf8Builder
getTimestamp logVerbose
| logVerbose && logUseTime lo =
do now <- getZonedTime
return $ ansi setBlack <> fromString (formatTime' now) <> ": "
| otherwise = return mempty
where
formatTime' =
take timestampLength . formatTime defaultTimeLocale "%F %T.%q"
getLevel :: Bool -> Utf8Builder
getLevel logVerbose
| logVerbose =
case level of
LevelDebug -> ansi setGreen <> "[debug] "
LevelInfo -> ansi setBlue <> "[info] "
LevelWarn -> ansi setYellow <> "[warn] "
LevelError -> ansi setRed <> "[error] "
LevelOther name ->
ansi setMagenta <>
"[" <>
display name <>
"] "
| otherwise = mempty
getLoc :: Utf8Builder
getLoc
| logUseLoc lo = ansi setBlack <> "\n@(" <> displayCallStack cs <> ")"
| otherwise = mempty
displayCallStack :: CallStack -> Utf8Builder
displayCallStack cs =
case reverse $ getCallStack cs of
[] -> "<no call stack found>"
(_desc, loc):_ ->
let file = srcLocFile loc
in fromString file <>
":" <>
displayShow (srcLocStartLine loc) <>
":" <>
displayShow (srcLocStartCol loc)
timestampLength :: Int
timestampLength =
length (formatTime defaultTimeLocale "%F %T.000000" (UTCTime (ModifiedJulianDay 0) 0))
stickyImpl
:: MVar ByteString -> LogOptions
-> (CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ())
-> CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO ()
stickyImpl ref lo logFunc loc src level msgOrig = modifyMVar_ ref $ \sticky -> do
let backSpaceChar = '\8'
repeating = mconcat . replicate (B.length sticky) . char7
clear = logSend lo
(repeating backSpaceChar <>
repeating ' ' <>
repeating backSpaceChar)
logLevel <- logMinLevel lo
case level of
LevelOther "sticky-done" -> do
clear
logFunc loc src LevelInfo msgOrig
return mempty
LevelOther "sticky" -> do
clear
let bs = toStrictBytes $ toLazyByteString $ getUtf8Builder msgOrig
logSend lo (byteString bs <> flush)
return bs
_
| level >= logLevel -> do
clear
logFunc loc src level msgOrig
unless (B.null sticky) $ logSend lo (byteString sticky <> flush)
return sticky
| otherwise -> return sticky
logFuncUseColorL :: HasLogFunc env => SimpleGetter env Bool
logFuncUseColorL = logFuncL.to (maybe False logUseColor . lfOptions)
noLogging :: (HasLogFunc env, MonadReader env m) => m a -> m a
noLogging = local (set logFuncL mempty)