{-# LANGUAGE FlexibleContexts #-}
module GHCup.Utils.Logger where
import GHCup.Types
import GHCup.Utils
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Logger
import HPath
import HPath.IO
import Prelude hiding ( appendFile )
import System.Console.Pretty
import System.IO.Error
import qualified Data.ByteString as B
data LoggerConfig = LoggerConfig
{ LoggerConfig -> Bool
lcPrintDebug :: Bool
, LoggerConfig -> ByteString -> IO ()
colorOutter :: B.ByteString -> IO ()
, LoggerConfig -> ByteString -> IO ()
rawOutter :: B.ByteString -> IO ()
}
myLoggerT :: LoggerConfig -> LoggingT m a -> m a
myLoggerT :: LoggerConfig -> LoggingT m a -> m a
myLoggerT LoggerConfig {Bool
ByteString -> IO ()
rawOutter :: ByteString -> IO ()
colorOutter :: ByteString -> IO ()
lcPrintDebug :: Bool
rawOutter :: LoggerConfig -> ByteString -> IO ()
colorOutter :: LoggerConfig -> ByteString -> IO ()
lcPrintDebug :: LoggerConfig -> Bool
..} LoggingT m a
loggingt = LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT LoggingT m a
loggingt Loc -> LogSource -> LogLevel -> LogStr -> IO ()
mylogger
where
mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
mylogger Loc
_ LogSource
_ LogLevel
level LogStr
str' = do
let l :: LogStr
l = case LogLevel
level of
LogLevel
LevelDebug -> [Char] -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Style -> [Char] -> [Char]
forall a. Pretty a => Style -> a -> a
style Style
Bold ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Color -> [Char] -> [Char]
forall a. Pretty a => Color -> a -> a
color Color
Blue [Char]
"[ Debug ]")
LogLevel
LevelInfo -> [Char] -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Style -> [Char] -> [Char]
forall a. Pretty a => Style -> a -> a
style Style
Bold ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Color -> [Char] -> [Char]
forall a. Pretty a => Color -> a -> a
color Color
Green [Char]
"[ Info ]")
LogLevel
LevelWarn -> [Char] -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Style -> [Char] -> [Char]
forall a. Pretty a => Style -> a -> a
style Style
Bold ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Color -> [Char] -> [Char]
forall a. Pretty a => Color -> a -> a
color Color
Yellow [Char]
"[ Warn ]")
LogLevel
LevelError -> [Char] -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Style -> [Char] -> [Char]
forall a. Pretty a => Style -> a -> a
style Style
Bold ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Color -> [Char] -> [Char]
forall a. Pretty a => Color -> a -> a
color Color
Red [Char]
"[ Error ]")
LevelOther LogSource
t -> [Char] -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr [Char]
"[ " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogSource -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr LogSource
t LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> [Char] -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr [Char]
" ]"
let out :: ByteString
out = LogStr -> ByteString
fromLogStr (LogStr
l LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> [Char] -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr [Char]
" " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
str' LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> [Char] -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr [Char]
"\n")
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
lcPrintDebug Bool -> Bool -> Bool
|| (Bool -> Bool
not Bool
lcPrintDebug Bool -> Bool -> Bool
&& (LogLevel
level LogLevel -> LogLevel -> Bool
forall a. Eq a => a -> a -> Bool
/= LogLevel
LevelDebug)))
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
colorOutter ByteString
out
let lr :: LogStr
lr = case LogLevel
level of
LogLevel
LevelDebug -> [Char] -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr [Char]
"Debug: "
LogLevel
LevelInfo -> [Char] -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr [Char]
"Info:"
LogLevel
LevelWarn -> [Char] -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr [Char]
"Warn:"
LogLevel
LevelError -> [Char] -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr [Char]
"Error:"
LevelOther LogSource
t -> LogSource -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr LogSource
t LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> [Char] -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr [Char]
":"
let outr :: ByteString
outr = LogStr -> ByteString
fromLogStr (LogStr
lr LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> [Char] -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr [Char]
" " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
str' LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> [Char] -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr [Char]
"\n")
ByteString -> IO ()
rawOutter ByteString
outr
initGHCupFileLogging :: (MonadIO m, MonadReader AppState m) => Path Rel -> m (Path Abs)
initGHCupFileLogging :: Path Rel -> m (Path Abs)
initGHCupFileLogging Path Rel
context = do
AppState {dirs :: AppState -> Dirs
dirs = Dirs {Path Abs
confDir :: Dirs -> Path Abs
logsDir :: Dirs -> Path Abs
cacheDir :: Dirs -> Path Abs
binDir :: Dirs -> Path Abs
baseDir :: Dirs -> Path Abs
confDir :: Path Abs
logsDir :: Path Abs
cacheDir :: Path Abs
binDir :: Path Abs
baseDir :: Path Abs
..}} <- m AppState
forall r (m :: * -> *). MonadReader r m => m r
ask
let logfile :: Path Abs
logfile = Path Abs
logsDir Path Abs -> Path Rel -> Path Abs
forall b. Path b -> Path Rel -> Path b
</> Path Rel
context
IO (Path Abs) -> m (Path Abs)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Path Abs) -> m (Path Abs)) -> IO (Path Abs) -> m (Path Abs)
forall a b. (a -> b) -> a -> b
$ do
Path Abs -> IO ()
forall b. Path b -> IO ()
createDirRecursive' Path Abs
logsDir
IOErrorType -> IO () -> IO ()
hideError IOErrorType
doesNotExistErrorType (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Path Abs -> IO ()
forall b. Path b -> IO ()
deleteFile Path Abs
logfile
FileMode -> Path Abs -> IO ()
forall b. FileMode -> Path b -> IO ()
createRegularFile FileMode
newFilePerms Path Abs
logfile
Path Abs -> IO (Path Abs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs
logfile