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

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

  -- * 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)

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

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
  (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, 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

readLogColor :: String -> Either String LogColor
readLogColor :: String -> Either String LogColor
readLogColor String
x
  | String
x String -> [String] -> 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 (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 (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 :: LogLevels -> LogDestination -> LogFormat -> LogColor -> LogSettings
LogSettings
  { lsLevels :: LogLevels
lsLevels = LogLevels
LogLevels.defaultLogLevels
  , lsDestination :: LogDestination
lsDestination = LogDestination
LogDestinationStdout
  , lsFormat :: LogFormat
lsFormat = LogFormat
LogFormatTerminal
  , lsColor :: LogColor
lsColor = LogColor
LogColorAuto
  }

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

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

setLogSettingsFormat :: LogFormat -> LogSettings -> LogSettings
setLogSettingsFormat :: LogFormat -> LogSettings -> LogSettings
setLogSettingsFormat LogFormat
x LogSettings
ls = LogSettings
ls { lsFormat :: LogFormat
lsFormat = LogFormat
x }

setLogSettingsColor :: LogColor -> LogSettings -> LogSettings
setLogSettingsColor :: LogColor -> LogSettings -> LogSettings
setLogSettingsColor LogColor
x LogSettings
ls = LogSettings
ls { lsColor :: LogColor
lsColor = LogColor
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

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 :: LogSettings -> m Bool -> m Bool
shouldColorAuto LogSettings {LogLevels
LogColor
LogFormat
LogDestination
lsColor :: LogColor
lsFormat :: LogFormat
lsDestination :: LogDestination
lsLevels :: LogLevels
lsColor :: LogSettings -> LogColor
lsFormat :: LogSettings -> LogFormat
lsDestination :: LogSettings -> LogDestination
lsLevels :: LogSettings -> LogLevels
..} m Bool
f = case LogColor
lsColor of
  LogColor
LogColorAuto -> m Bool
f
  LogColor
LogColorAlways -> Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  LogColor
LogColorNever -> Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

shouldColorHandle :: MonadIO m => LogSettings -> Handle -> m Bool
shouldColorHandle :: 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 (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