{-|
Module      : Instana.SDK.Internal.Logging
Description : Handles logging
-}
module Instana.SDK.Internal.Logging
  ( initLogger
  , instanaLogger

  -- exposed for testing
  , parseLogLevel
  -- exposed for testing
  , minimumLogLevel
  )
  where


import           Control.Monad             (when)
import           Data.Maybe                (catMaybes, isJust)
import qualified Data.Text                 as T
import           System.Directory          (getTemporaryDirectory)
import           System.Environment        (lookupEnv)
import           System.IO                 (Handle, stdout)
import           System.Log.Formatter
import           System.Log.Handler        (setFormatter)
import           System.Log.Handler.Simple (GenericHandler, fileHandler,
                                            streamHandler)
import           System.Log.Logger         (Priority (..), rootLoggerName,
                                            setHandlers, setLevel,
                                            updateGlobalLogger)


{-| Minimum Log level for messages written to the Instana Haskell SDK log file.
If not set, or set to an invalid log level, no log file will be created. If set
to a valid level, a log file named "instana-haskell-sdk.${pid}.log" will be
created in the system temp directory.

If neither this nor INSTANA_LOG_LEVEL_STDOUT are set, the Instana Haskell SDK
will not emit any log messages at all.
-}
logLevelKey :: String
logLevelKey :: String
logLevelKey = "INSTANA_LOG_LEVEL"


{-| Minimum Log level for messages written to stdout. This option should only be
used during development. If not set, or set to an invalid log level, no log
messages will be written to stdout.

If neither this nor INSTANA_LOG_LEVEL are set, the Instana Haskell SDK
will not emit any log messages at all.
-}
logLevelStdOutKey :: String
logLevelStdOutKey :: String
logLevelStdOutKey = "INSTANA_LOG_LEVEL_STDOUT"


{-| If neither this nor INSTANA_LOG_LEVEL are set, this setting is irrelevant
and will be ignored.

Otherwise, if this is set to a non-empty string, a stdout logging handler will
be attached to the root logger instead of the Instana Haskell SDK logger, i. e.:

    updateGlobalLogger rootLoggerName $ setHandlers instanaStdOutHandler

will be called. When INSTANA_LOG_LEVEL_STDOUT is also set, that log level will
be used, otherwise the highest log level (EMERGENCY) will be used for the
handler.

This setting should be used if no other part of the running process (for example
the app which uses the Instana Haskell SDK) has already configured hslogger. In
particular, if this has not been set, the assumption is that "someone else" will
execute something like this with the root logger:

    updateGlobalLogger rootLoggerName $ setHandlers [ ..., appStdOutHandler, ... ]

This is is necessary to avoid emitting all Instana log messages to stdout or to
avoid duplicating log messages on stdout in case INSTANA_LOG_LEVEL_STDOUT is
set.
See https://stackoverflow.com/a/40995265
-}
overrideHsloggerRootHandlerKey :: String
overrideHsloggerRootHandlerKey :: String
overrideHsloggerRootHandlerKey = "INSTANA_OVERRIDE_HSLOGGER_ROOT_HANDLER"


-- |The SDK's logger name.
instanaLogger :: String
instanaLogger :: String
instanaLogger = "Instana"


-- |Initializes the SDK's logging.
initLogger :: String -> IO ()
initLogger :: String -> IO ()
initLogger pid :: String
pid = do
  Maybe String
logLevelFileStr <- String -> IO (Maybe String)
lookupEnv String
logLevelKey
  Maybe String
logLevelStdOutStr <- String -> IO (Maybe String)
lookupEnv String
logLevelStdOutKey
  let
    logLevelFile :: Maybe Priority
logLevelFile = Maybe String
logLevelFileStr Maybe String -> (String -> Maybe Priority) -> Maybe Priority
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Priority
parseLogLevel
    logLevelStdOut :: Maybe Priority
logLevelStdOut = Maybe String
logLevelStdOutStr Maybe String -> (String -> Maybe Priority) -> Maybe Priority
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Priority
parseLogLevel

  let
    minLogLevel :: Maybe Priority
minLogLevel = Maybe Priority -> Maybe Priority -> Maybe Priority
minimumLogLevel Maybe Priority
logLevelFile Maybe Priority
logLevelStdOut

  case Maybe Priority
minLogLevel of
    Just minLevel :: Priority
minLevel ->
      String -> Priority -> Maybe Priority -> Maybe Priority -> IO ()
actuallyInitLogger String
pid Priority
minLevel Maybe Priority
logLevelFile Maybe Priority
logLevelStdOut
    Nothing -> do
      () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


actuallyInitLogger ::
  String ->
  Priority ->
  Maybe Priority ->
  Maybe Priority ->
  IO ()
actuallyInitLogger :: String -> Priority -> Maybe Priority -> Maybe Priority -> IO ()
actuallyInitLogger pid :: String
pid minLogLevel :: Priority
minLogLevel logLevelFile :: Maybe Priority
logLevelFile logLevelStdOut :: Maybe Priority
logLevelStdOut = do
  String -> (Logger -> Logger) -> IO ()
updateGlobalLogger String
instanaLogger ((Logger -> Logger) -> IO ()) -> (Logger -> Logger) -> IO ()
forall a b. (a -> b) -> a -> b
$ Priority -> Logger -> Logger
setLevel Priority
minLogLevel
  Maybe (GenericHandler Handle)
logFileHandler <-
    Maybe (IO (GenericHandler Handle))
-> IO (Maybe (GenericHandler Handle))
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Maybe (IO (GenericHandler Handle))
 -> IO (Maybe (GenericHandler Handle)))
-> Maybe (IO (GenericHandler Handle))
-> IO (Maybe (GenericHandler Handle))
forall a b. (a -> b) -> a -> b
$
      (\logLevel :: Priority
logLevel -> String -> Priority -> IO (GenericHandler Handle)
createFileHandler String
pid Priority
logLevel) (Priority -> IO (GenericHandler Handle))
-> Maybe Priority -> Maybe (IO (GenericHandler Handle))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Priority
logLevelFile
  Maybe (GenericHandler Handle)
stdOutHandler <-
    Maybe (IO (GenericHandler Handle))
-> IO (Maybe (GenericHandler Handle))
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Maybe (IO (GenericHandler Handle))
 -> IO (Maybe (GenericHandler Handle)))
-> Maybe (IO (GenericHandler Handle))
-> IO (Maybe (GenericHandler Handle))
forall a b. (a -> b) -> a -> b
$
      (\logLevel :: Priority
logLevel -> Priority -> IO (GenericHandler Handle)
createStdOutHandler Priority
logLevel) (Priority -> IO (GenericHandler Handle))
-> Maybe Priority -> Maybe (IO (GenericHandler Handle))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Priority
logLevelStdOut
  Maybe (GenericHandler Handle)
-> Maybe (GenericHandler Handle) -> IO ()
setLogHandlers Maybe (GenericHandler Handle)
logFileHandler Maybe (GenericHandler Handle)
stdOutHandler


createFileHandler :: String -> Priority -> IO (GenericHandler Handle)
createFileHandler :: String -> Priority -> IO (GenericHandler Handle)
createFileHandler pid :: String
pid logLevel :: Priority
logLevel = do
  String
systemTempDir <- IO String
getTemporaryDirectory
  let
    systemTempDir' :: String
systemTempDir' =
      case String -> Char
forall a. [a] -> a
last String
systemTempDir of
        '/'  -> String
systemTempDir
        '\\' -> String
systemTempDir
        _    -> String
systemTempDir String -> String -> String
forall a. [a] -> [a] -> [a]
++ "/"
    logPath :: String
logPath = String
systemTempDir' String -> String -> String
forall a. [a] -> [a] -> [a]
++ "instana-haskell-sdk." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pid String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".log"
  GenericHandler Handle
instanaFileHandler <- String -> Priority -> IO (GenericHandler Handle)
fileHandler String
logPath Priority
logLevel
  let
    formattedInstanaFileHandler :: GenericHandler Handle
formattedInstanaFileHandler = GenericHandler Handle -> GenericHandler Handle
withFormatter GenericHandler Handle
instanaFileHandler
  GenericHandler Handle -> IO (GenericHandler Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return GenericHandler Handle
formattedInstanaFileHandler


createStdOutHandler :: Priority -> IO (GenericHandler Handle)
createStdOutHandler :: Priority -> IO (GenericHandler Handle)
createStdOutHandler logLevel :: Priority
logLevel = do
  GenericHandler Handle
instanaStreamHandler <- Handle -> Priority -> IO (GenericHandler Handle)
streamHandler Handle
stdout Priority
logLevel
  let
    formattedInstanaStreamHandler :: GenericHandler Handle
formattedInstanaStreamHandler = GenericHandler Handle -> GenericHandler Handle
withFormatter GenericHandler Handle
instanaStreamHandler
  GenericHandler Handle -> IO (GenericHandler Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return GenericHandler Handle
formattedInstanaStreamHandler


setLogHandlers ::
  Maybe (GenericHandler Handle)
  -> Maybe (GenericHandler Handle)
  -> IO ()
setLogHandlers :: Maybe (GenericHandler Handle)
-> Maybe (GenericHandler Handle) -> IO ()
setLogHandlers logFileHandler :: Maybe (GenericHandler Handle)
logFileHandler stdOutHandler :: Maybe (GenericHandler Handle)
stdOutHandler = do
  Maybe String
overrideHsloggerRootHandlerVal <-
    String -> IO (Maybe String)
lookupEnv String
overrideHsloggerRootHandlerKey
  let
    overrideHsloggerRootHandler :: Bool
overrideHsloggerRootHandler =
      Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
overrideHsloggerRootHandlerVal

    handlers :: [GenericHandler Handle]
handlers =
      [Maybe (GenericHandler Handle)] -> [GenericHandler Handle]
forall a. [Maybe a] -> [a]
catMaybes
        [ Maybe (GenericHandler Handle)
logFileHandler
        , if Bool
overrideHsloggerRootHandler
          then Maybe (GenericHandler Handle)
forall a. Maybe a
Nothing
          else Maybe (GenericHandler Handle)
stdOutHandler
        ]

  String -> (Logger -> Logger) -> IO ()
updateGlobalLogger String
instanaLogger ((Logger -> Logger) -> IO ()) -> (Logger -> Logger) -> IO ()
forall a b. (a -> b) -> a -> b
$ [GenericHandler Handle] -> Logger -> Logger
forall a. LogHandler a => [a] -> Logger -> Logger
setHandlers [GenericHandler Handle]
handlers

  -- override stdout handler on root logger level if requested
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
overrideHsloggerRootHandler
    (do
      GenericHandler Handle
actualStdOutHandler <-
        case Maybe (GenericHandler Handle)
stdOutHandler of
          Just handler :: GenericHandler Handle
handler ->
            GenericHandler Handle -> IO (GenericHandler Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return GenericHandler Handle
handler
          Nothing ->
            Priority -> IO (GenericHandler Handle)
createStdOutHandler Priority
EMERGENCY
      let
        overrideRootHhandlers :: [GenericHandler Handle]
overrideRootHhandlers = [ GenericHandler Handle
actualStdOutHandler ]
      String -> (Logger -> Logger) -> IO ()
updateGlobalLogger String
rootLoggerName ((Logger -> Logger) -> IO ()) -> (Logger -> Logger) -> IO ()
forall a b. (a -> b) -> a -> b
$ [GenericHandler Handle] -> Logger -> Logger
forall a. LogHandler a => [a] -> Logger -> Logger
setHandlers [GenericHandler Handle]
overrideRootHhandlers
    )


withFormatter :: GenericHandler Handle -> GenericHandler Handle
withFormatter :: GenericHandler Handle -> GenericHandler Handle
withFormatter handler :: GenericHandler Handle
handler = GenericHandler Handle
-> LogFormatter (GenericHandler Handle) -> GenericHandler Handle
forall a. LogHandler a => a -> LogFormatter a -> a
setFormatter GenericHandler Handle
handler LogFormatter (GenericHandler Handle)
forall a. LogFormatter a
formatter
    -- http://hackage.haskell.org/packages/archive/hslogger/1.1.4/doc/html/System-Log-Formatter.html
    where
      timeFormat :: String
timeFormat = "%F %H:%M:%S.%4q %z"
      formatter :: LogFormatter a
formatter = String -> String -> LogFormatter a
forall a. String -> String -> LogFormatter a
tfLogFormatter String
timeFormat "[$time $loggername $pid $prio] $msg"


-- |Parses a string into a hslogger log level.
parseLogLevel :: String -> Maybe Priority
parseLogLevel :: String -> Maybe Priority
parseLogLevel logLevelStr :: String
logLevelStr =
  case (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toUpper (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
logLevelStr) of
    "DEBUG"     -> Priority -> Maybe Priority
forall a. a -> Maybe a
Just Priority
DEBUG
    "INFO"      -> Priority -> Maybe Priority
forall a. a -> Maybe a
Just Priority
INFO
    "NOTICE"    -> Priority -> Maybe Priority
forall a. a -> Maybe a
Just Priority
NOTICE
    "WARNING"   -> Priority -> Maybe Priority
forall a. a -> Maybe a
Just Priority
WARNING
    "ERROR"     -> Priority -> Maybe Priority
forall a. a -> Maybe a
Just Priority
ERROR
    "CRITICAL"  -> Priority -> Maybe Priority
forall a. a -> Maybe a
Just Priority
CRITICAL
    "ALERT"     -> Priority -> Maybe Priority
forall a. a -> Maybe a
Just Priority
ALERT
    "EMERGENCY" -> Priority -> Maybe Priority
forall a. a -> Maybe a
Just Priority
EMERGENCY
    _           -> Maybe Priority
forall a. Maybe a
Nothing


-- |Calculates the minimum of two log levels.
minimumLogLevel :: Maybe Priority -> Maybe Priority -> Maybe Priority
minimumLogLevel :: Maybe Priority -> Maybe Priority -> Maybe Priority
minimumLogLevel (Just l1 :: Priority
l1) (Just l2 :: Priority
l2) = Priority -> Maybe Priority
forall a. a -> Maybe a
Just (Priority -> Maybe Priority) -> Priority -> Maybe Priority
forall a b. (a -> b) -> a -> b
$ Priority -> Priority -> Priority
forall a. Ord a => a -> a -> a
min Priority
l1 Priority
l2
minimumLogLevel (Just l :: Priority
l) Nothing    = Priority -> Maybe Priority
forall a. a -> Maybe a
Just Priority
l
minimumLogLevel Nothing (Just l :: Priority
l)    = Priority -> Maybe Priority
forall a. a -> Maybe a
Just Priority
l
minimumLogLevel _ _                 = Maybe Priority
forall a. Maybe a
Nothing