{-# LANGUAGE FlexibleContexts      #-}

{-|
Module      : GHCup.Utils.Logger
Description : logger definition
Copyright   : (c) Julian Ospald, 2020
License     : LGPL-3.0
Maintainer  : hasufell@hasufell.de
Stability   : experimental
Portability : POSIX

Here we define our main logger.
-}
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                  -- ^ whether to print debug in colorOutter
  , LoggerConfig -> ByteString -> IO ()
colorOutter  :: B.ByteString -> IO () -- ^ how to write the color output
  , LoggerConfig -> ByteString -> IO ()
rawOutter    :: B.ByteString -> IO () -- ^ how to write the full raw output
  }


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
    -- color output
    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

    -- raw output
    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