module Blammo.Logging.LogSettings
  ( LogSettings
  , LogLevels
  , LogDestination (..)
  , LogFormat (..)
  , LogColor (..)

    -- * Reading settings, e.g. from @ENV@
  , readLogLevels
  , readLogDestination
  , readLogFormat
  , readLogColor

    -- * Construction
  , defaultLogSettings

    -- * Modify
  , setLogSettingsLevels
  , setLogSettingsDestination
  , setLogSettingsFormat
  , setLogSettingsColor
  , setLogSettingsBreakpoint
  , setLogSettingsConcurrency

    -- * Access
  , getLogSettingsLevels
  , getLogSettingsDestination
  , getLogSettingsFormat
  , getLogSettingsColor
  , getLogSettingsBreakpoint
  , getLogSettingsConcurrency

    -- * Logic
  , shouldLogLevel
  , shouldColorAuto
  , shouldColorHandle
  ) where

import Prelude

import Blammo.Logging.LogSettings.LogLevels (LogLevels)
import qualified Blammo.Logging.LogSettings.LogLevels as LogLevels
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Logger.Aeson
import System.IO (Handle, hIsTerminalDevice)
import qualified System.Info

data LogSettings = LogSettings
  { LogSettings -> LogLevels
lsLevels :: LogLevels
  , LogSettings -> LogDestination
lsDestination :: LogDestination
  , LogSettings -> LogFormat
lsFormat :: LogFormat
  , LogSettings -> LogColor
lsColor :: LogColor
  , LogSettings -> Int
lsBreakpoint :: Int
  , LogSettings -> Maybe Int
lsConcurrency :: Maybe Int
  }

readLogLevels :: String -> Either String LogLevels
readLogLevels :: String -> Either String LogLevels
readLogLevels = String -> Either String LogLevels
LogLevels.readLogLevels

data LogDestination
  = LogDestinationStdout
  | LogDestinationStderr
  | LogDestinationFile FilePath

readLogDestination :: String -> Either String LogDestination
readLogDestination :: String -> Either String LogDestination
readLogDestination = \case
  String
"stdout" -> LogDestination -> Either String LogDestination
forall a b. b -> Either a b
Right LogDestination
LogDestinationStdout
  String
"stderr" -> LogDestination -> Either String LogDestination
forall a b. b -> Either a b
Right LogDestination
LogDestinationStderr
  String
"null" -> LogDestination -> Either String LogDestination
forall a b. b -> Either a b
Right (LogDestination -> Either String LogDestination)
-> LogDestination -> Either String LogDestination
forall a b. (a -> b) -> a -> b
$ String -> LogDestination
LogDestinationFile String
nullDevice
  (Char
'@' : String
path) -> LogDestination -> Either String LogDestination
forall a b. b -> Either a b
Right (LogDestination -> Either String LogDestination)
-> LogDestination -> Either String LogDestination
forall a b. (a -> b) -> a -> b
$ String -> LogDestination
LogDestinationFile String
path
  String
x ->
    String -> Either String LogDestination
forall a b. a -> Either a b
Left (String -> Either String LogDestination)
-> String -> Either String LogDestination
forall a b. (a -> b) -> a -> b
$
      String
"Invalid log destination "
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
x
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", must be stdout, stderr, null, or @{path}"

data LogFormat
  = LogFormatJSON
  | LogFormatTerminal

readLogFormat :: String -> Either String LogFormat
readLogFormat :: String -> Either String LogFormat
readLogFormat = \case
  String
"tty" -> LogFormat -> Either String LogFormat
forall a b. b -> Either a b
Right LogFormat
LogFormatTerminal
  String
"json" -> LogFormat -> Either String LogFormat
forall a b. b -> Either a b
Right LogFormat
LogFormatJSON
  String
x -> String -> Either String LogFormat
forall a b. a -> Either a b
Left (String -> Either String LogFormat)
-> String -> Either String LogFormat
forall a b. (a -> b) -> a -> b
$ String
"Invalid log format " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", must be tty or json"

data LogColor
  = LogColorAuto
  | LogColorAlways
  | LogColorNever
  deriving stock (LogColor -> LogColor -> Bool
(LogColor -> LogColor -> Bool)
-> (LogColor -> LogColor -> Bool) -> Eq LogColor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LogColor -> LogColor -> Bool
== :: LogColor -> LogColor -> Bool
$c/= :: LogColor -> LogColor -> Bool
/= :: LogColor -> LogColor -> Bool
Eq, Int -> LogColor -> String -> String
[LogColor] -> String -> String
LogColor -> String
(Int -> LogColor -> String -> String)
-> (LogColor -> String)
-> ([LogColor] -> String -> String)
-> Show LogColor
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> LogColor -> String -> String
showsPrec :: Int -> LogColor -> String -> String
$cshow :: LogColor -> String
show :: LogColor -> String
$cshowList :: [LogColor] -> String -> String
showList :: [LogColor] -> String -> String
Show)

readLogColor :: String -> Either String LogColor
readLogColor :: String -> Either String LogColor
readLogColor String
x
  | String
x String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
autoValues =
      LogColor -> Either String LogColor
forall a b. b -> Either a b
Right LogColor
LogColorAuto
  | String
x String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
alwaysValues =
      LogColor -> Either String LogColor
forall a b. b -> Either a b
Right LogColor
LogColorAlways
  | String
x String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
neverValues =
      LogColor -> Either String LogColor
forall a b. b -> Either a b
Right LogColor
LogColorNever
  | Bool
otherwise =
      String -> Either String LogColor
forall a b. a -> Either a b
Left (String -> Either String LogColor)
-> String -> Either String LogColor
forall a b. (a -> b) -> a -> b
$ String
"Invalid log color " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", must be auto, always, or never"
 where
  autoValues :: [String]
  autoValues :: [String]
autoValues = [String
"auto"]

  alwaysValues :: [String]
  alwaysValues :: [String]
alwaysValues = [String
"always", String
"on", String
"yes", String
"true"]

  neverValues :: [String]
  neverValues :: [String]
neverValues = [String
"never", String
"off", String
"no", String
"false"]

defaultLogSettings :: LogSettings
defaultLogSettings :: LogSettings
defaultLogSettings =
  LogSettings
    { lsLevels :: LogLevels
lsLevels = LogLevels
LogLevels.defaultLogLevels
    , lsDestination :: LogDestination
lsDestination = LogDestination
LogDestinationStdout
    , lsFormat :: LogFormat
lsFormat = LogFormat
LogFormatTerminal
    , lsColor :: LogColor
lsColor = LogColor
LogColorAuto
    , lsBreakpoint :: Int
lsBreakpoint = Int
120
    , lsConcurrency :: Maybe Int
lsConcurrency = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
    }

setLogSettingsLevels :: LogLevels -> LogSettings -> LogSettings
setLogSettingsLevels :: LogLevels -> LogSettings -> LogSettings
setLogSettingsLevels LogLevels
x LogSettings
ls = LogSettings
ls {lsLevels = x}

setLogSettingsDestination :: LogDestination -> LogSettings -> LogSettings
setLogSettingsDestination :: LogDestination -> LogSettings -> LogSettings
setLogSettingsDestination LogDestination
x LogSettings
ls = LogSettings
ls {lsDestination = x}

setLogSettingsFormat :: LogFormat -> LogSettings -> LogSettings
setLogSettingsFormat :: LogFormat -> LogSettings -> LogSettings
setLogSettingsFormat LogFormat
x LogSettings
ls = case LogFormat
x of
  LogFormat
LogFormatTerminal ->
    LogSettings
ls
      { lsFormat = x
      , lsConcurrency = Just 1
      }
  LogFormat
_ ->
    LogSettings
ls
      { lsFormat = x
      , lsConcurrency = Nothing
      }

setLogSettingsColor :: LogColor -> LogSettings -> LogSettings
setLogSettingsColor :: LogColor -> LogSettings -> LogSettings
setLogSettingsColor LogColor
x LogSettings
ls = LogSettings
ls {lsColor = x}

setLogSettingsBreakpoint :: Int -> LogSettings -> LogSettings
setLogSettingsBreakpoint :: Int -> LogSettings -> LogSettings
setLogSettingsBreakpoint Int
x LogSettings
ls = LogSettings
ls {lsBreakpoint = x}

-- | Set the number of 'LoggerSet' Buffers used by @fast-logger@
--
-- A value of 'Nothing' means to use 'getNumCapabilities'. Higher is more
-- performant, but may deliver messages out of order. The defualt is set for TTY
-- usage (so, @1@), but is also changed through 'setLogSettingsFormat' is used.
--
-- Support for this option depends on your version of @fast-logger@:
--
-- +-----------------------------+------------+
-- | fast-logger | Destination   | Supported? |
-- +=============+===============+============+
-- | >=3.1.1     | anywhere      | yes        |
-- +-----------------------------+------------+
-- | >=3.0.5     | file          | yes        |
-- +-----------------------------+------------+
-- | >=3.0.5     | stdout/stderr | no         |
-- +-----------------------------+------------+
-- |  <3.0.5     | anywhere      | no         |
-- +-----------------------------+------------+
setLogSettingsConcurrency :: Maybe Int -> LogSettings -> LogSettings
setLogSettingsConcurrency :: Maybe Int -> LogSettings -> LogSettings
setLogSettingsConcurrency Maybe Int
x LogSettings
ls = LogSettings
ls {lsConcurrency = x}

getLogSettingsLevels :: LogSettings -> LogLevels
getLogSettingsLevels :: LogSettings -> LogLevels
getLogSettingsLevels = LogSettings -> LogLevels
lsLevels

getLogSettingsDestination :: LogSettings -> LogDestination
getLogSettingsDestination :: LogSettings -> LogDestination
getLogSettingsDestination = LogSettings -> LogDestination
lsDestination

getLogSettingsFormat :: LogSettings -> LogFormat
getLogSettingsFormat :: LogSettings -> LogFormat
getLogSettingsFormat = LogSettings -> LogFormat
lsFormat

getLogSettingsColor :: LogSettings -> LogColor
getLogSettingsColor :: LogSettings -> LogColor
getLogSettingsColor = LogSettings -> LogColor
lsColor

getLogSettingsBreakpoint :: LogSettings -> Int
getLogSettingsBreakpoint :: LogSettings -> Int
getLogSettingsBreakpoint = LogSettings -> Int
lsBreakpoint

getLogSettingsConcurrency :: LogSettings -> Maybe Int
getLogSettingsConcurrency :: LogSettings -> Maybe Int
getLogSettingsConcurrency = LogSettings -> Maybe Int
lsConcurrency

shouldLogLevel :: LogSettings -> LogSource -> LogLevel -> Bool
shouldLogLevel :: LogSettings -> LogSource -> LogLevel -> Bool
shouldLogLevel = LogLevels -> LogSource -> LogLevel -> Bool
LogLevels.shouldLogLevel (LogLevels -> LogSource -> LogLevel -> Bool)
-> (LogSettings -> LogLevels)
-> LogSettings
-> LogSource
-> LogLevel
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogSettings -> LogLevels
getLogSettingsLevels

shouldColorAuto :: Applicative m => LogSettings -> m Bool -> m Bool
shouldColorAuto :: forall (m :: * -> *).
Applicative m =>
LogSettings -> m Bool -> m Bool
shouldColorAuto LogSettings {Int
Maybe Int
LogLevels
LogColor
LogFormat
LogDestination
lsLevels :: LogSettings -> LogLevels
lsDestination :: LogSettings -> LogDestination
lsFormat :: LogSettings -> LogFormat
lsColor :: LogSettings -> LogColor
lsBreakpoint :: LogSettings -> Int
lsConcurrency :: LogSettings -> Maybe Int
lsLevels :: LogLevels
lsDestination :: LogDestination
lsFormat :: LogFormat
lsColor :: LogColor
lsBreakpoint :: Int
lsConcurrency :: Maybe Int
..} m Bool
f = case LogColor
lsColor of
  LogColor
LogColorAuto -> m Bool
f
  LogColor
LogColorAlways -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  LogColor
LogColorNever -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

shouldColorHandle :: MonadIO m => LogSettings -> Handle -> m Bool
shouldColorHandle :: forall (m :: * -> *). MonadIO m => LogSettings -> Handle -> m Bool
shouldColorHandle LogSettings
settings Handle
h =
  LogSettings -> m Bool -> m Bool
forall (m :: * -> *).
Applicative m =>
LogSettings -> m Bool -> m Bool
shouldColorAuto LogSettings
settings (m Bool -> m Bool) -> m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hIsTerminalDevice Handle
h

-- | @/dev/null@ or @NUL@ on windows
--
-- See <https://stackoverflow.com/a/58177337>.
nullDevice :: FilePath
nullDevice :: String
nullDevice
  | String
System.Info.os String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
windowsOS = String
"\\\\.\\NUL"
  | Bool
otherwise = String
"/dev/null"

windowsOS :: String
windowsOS :: String
windowsOS = String
"mingw32"