{-# LANGUAGE OverloadedStrings #-}

{- |
  Description: Logging utilities.

  Various combinators for composing "monad-logger" loggers.
-}
module OM.Logging (
  -- * Standard OM logging
  standardLogging,
  withStandardFormat,

  -- * Logging Combinators
  withTime,
  withThread,
  withLevel,
  withPrefix,
  withPackage,

  -- ** Filters
  filterLogging,
  levelFilter,

  -- ** Destinations
  teeLogging,
  stdoutLogging,
  fdLogging,

  -- * Other types
  parseLevel,
  JSONLevel(..),
) where


import Control.Concurrent (myThreadId)
import Control.Monad (when)
import Control.Monad.Logger (LogLevel(LevelDebug, LevelError, LevelInfo,
  LevelOther, LevelWarn), Loc, LogSource, LogStr, loc_package)
import Data.Aeson (FromJSON(parseJSON), Value(String))
import Data.List (intercalate)
import Data.List.Split (splitOn)
import Data.String (IsString)
import Data.Text (Text)
import Data.Time (getCurrentTime)
import Data.Time.Format (defaultTimeLocale, formatTime)
import OM.Show (showt)
import System.IO (Handle, hFlush, stdout)
import System.Log.FastLogger (fromLogStr, toLogStr)
import qualified Data.ByteString.Char8 as BS8
import qualified Data.Text as T


{- | Log to more than one logging destination. -}
teeLogging
  :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) {- ^ Destination 1. -}
  -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) {- ^ Destination 2. -}
  -> Loc
  -> LogSource
  -> LogLevel
  -> LogStr
  -> IO ()
teeLogging :: (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Loc
-> Text
-> LogLevel
-> LogStr
-> IO ()
teeLogging Loc -> Text -> LogLevel -> LogStr -> IO ()
logging1 Loc -> Text -> LogLevel -> LogStr -> IO ()
logging2 Loc
loc Text
src LogLevel
level LogStr
msg = do
  Loc -> Text -> LogLevel -> LogStr -> IO ()
logging1 Loc
loc Text
src LogLevel
level LogStr
msg
  Loc -> Text -> LogLevel -> LogStr -> IO ()
logging2 Loc
loc Text
src LogLevel
level LogStr
msg


{- |
  Filter out some log messages. Only messages matching the predicate
  are logged to the underlying logger.
-}
filterLogging
  :: (Loc -> LogSource -> LogLevel -> LogStr -> Bool)
     {- ^ The filter to apply. -}
  -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
     {- ^ The downstream logging destination. -}
  -> Loc
  -> LogSource
  -> LogLevel
  -> LogStr
  -> IO ()
filterLogging :: (Loc -> Text -> LogLevel -> LogStr -> Bool)
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Loc
-> Text
-> LogLevel
-> LogStr
-> IO ()
filterLogging Loc -> Text -> LogLevel -> LogStr -> Bool
p Loc -> Text -> LogLevel -> LogStr -> IO ()
base Loc
loc Text
src LogLevel
level LogStr
msg =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Loc -> Text -> LogLevel -> LogStr -> Bool
p Loc
loc Text
src LogLevel
level LogStr
msg)
    (Loc -> Text -> LogLevel -> LogStr -> IO ()
base Loc
loc Text
src LogLevel
level LogStr
msg)


{- |
  @levelFilter level@ is a filter predicate that matches all log messages
  with @level@ or above.
-}
levelFilter :: LogLevel -> Loc -> LogSource -> LogLevel -> LogStr -> Bool
levelFilter :: LogLevel -> Loc -> Text -> LogLevel -> LogStr -> Bool
levelFilter LogLevel
target Loc
_ Text
_ LogLevel
level LogStr
_ = LogLevel
level LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
target


{- | Prepend the 'Control.Concurrent.ThreadId' to the beginning of the log. -}
withThread
  :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
  -> Loc
  -> LogSource
  -> LogLevel
  -> LogStr
  -> IO ()
withThread :: (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Loc -> Text -> LogLevel -> LogStr -> IO ()
withThread Loc -> Text -> LogLevel -> LogStr -> IO ()
base Loc
loc Text
src LogLevel
level LogStr
msg = do
  ThreadId
tid <- IO ThreadId
myThreadId
  Loc -> Text -> LogLevel -> LogStr -> IO ()
base Loc
loc Text
src LogLevel
level (Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Text -> Text
forall s. (IsString s, Monoid s) => s -> s
squareBracket (ThreadId -> Text
forall a b. (Show a, IsString b) => a -> b
showt ThreadId
tid :: Text)) LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
msg)


{- | Add timing information to the beginning of logs. -}
withTime
  :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
  -> Loc
  -> LogSource
  -> LogLevel
  -> LogStr
  -> IO ()
withTime :: (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Loc -> Text -> LogLevel -> LogStr -> IO ()
withTime Loc -> Text -> LogLevel -> LogStr -> IO ()
base Loc
loc Text
src LogLevel
level LogStr
msg = do
  UTCTime
now <- IO UTCTime
getCurrentTime
  let
    time :: LogStr
    time :: LogStr
time =
      Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr
      (Text -> LogStr) -> (UTCTime -> Text) -> UTCTime -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
forall s. (IsString s, Monoid s) => s -> s
squareBracket
      (Text -> Text) -> (UTCTime -> Text) -> UTCTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
      (String -> Text) -> (UTCTime -> String) -> UTCTime -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S%06Q %Z"
      (UTCTime -> LogStr) -> UTCTime -> LogStr
forall a b. (a -> b) -> a -> b
$ UTCTime
now
  Loc -> Text -> LogLevel -> LogStr -> IO ()
base Loc
loc Text
src LogLevel
level (LogStr
time LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
msg)


{- | Add the originating package to the log message. -}
withPackage
  :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
  -> Loc
  -> LogSource
  -> LogLevel
  -> LogStr
  -> IO ()
withPackage :: (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Loc -> Text -> LogLevel -> LogStr -> IO ()
withPackage Loc -> Text -> LogLevel -> LogStr -> IO ()
base Loc
loc Text
src LogLevel
level LogStr
msg =
  let
    {-
      The package information looks like this
      `om-legion-6.4.1.1-LnoDD8xLijN7DglolZGFIp`, but we only want the
      actual package name, which is why we do the `reverse . split`
      business.
    -}
    package :: LogStr
package =
      String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr
      (String -> LogStr) -> (String -> String) -> String -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall s. (IsString s, Monoid s) => s -> s
squareBracket
      (String -> LogStr) -> String -> LogStr
forall a b. (a -> b) -> a -> b
$ case
          [String] -> [String]
forall a. [a] -> [a]
reverse
          ([String] -> [String]) -> (Loc -> [String]) -> Loc -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"-"
          (String -> [String]) -> (Loc -> String) -> Loc -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> String
loc_package
          (Loc -> [String]) -> Loc -> [String]
forall a b. (a -> b) -> a -> b
$ Loc
loc
        of
          String
_hash : String
_version : [String]
nameComponents ->
            String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-" ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
nameComponents)
          [String]
_ -> Loc -> String
loc_package Loc
loc
  in Loc -> Text -> LogLevel -> LogStr -> IO ()
base Loc
loc Text
src LogLevel
level (LogStr
package LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
msg)


{- | Add the Logging level to the log output. -}
withLevel
  :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
  -> Loc
  -> LogSource
  -> LogLevel
  -> LogStr
  -> IO ()
withLevel :: (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Loc -> Text -> LogLevel -> LogStr -> IO ()
withLevel Loc -> Text -> LogLevel -> LogStr -> IO ()
base Loc
loc Text
src LogLevel
level LogStr
msg =
  let
    levelStr :: LogStr
    levelStr :: LogStr
levelStr = LogStr -> LogStr
forall s. (IsString s, Monoid s) => s -> s
squareBracket (LogStr -> LogStr) -> (LogLevel -> LogStr) -> LogLevel -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Text -> LogStr) -> (LogLevel -> Text) -> LogLevel -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogLevel -> Text
showLevel (LogLevel -> LogStr) -> LogLevel -> LogStr
forall a b. (a -> b) -> a -> b
$ LogLevel
level
  in
    Loc -> Text -> LogLevel -> LogStr -> IO ()
base Loc
loc Text
src LogLevel
level (LogStr
levelStr LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
msg)


{- | Prefix a fixed string to the log output. -}
withPrefix
  :: LogStr
  -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
  -> Loc
  -> LogSource
  -> LogLevel
  -> LogStr
  -> IO ()
withPrefix :: LogStr
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Loc
-> Text
-> LogLevel
-> LogStr
-> IO ()
withPrefix LogStr
prefix Loc -> Text -> LogLevel -> LogStr -> IO ()
base Loc
loc Text
src LogLevel
level LogStr
msg =
  Loc -> Text -> LogLevel -> LogStr -> IO ()
base Loc
loc Text
src LogLevel
level (LogStr
prefix LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
msg)


{- | Help with putting things in square brackets. -}
squareBracket :: (IsString s, Monoid s) => s -> s
squareBracket :: forall s. (IsString s, Monoid s) => s -> s
squareBracket s
t = s
"[" s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
t s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
"]"


{- | Stringify a log level. -}
showLevel :: LogLevel -> Text
showLevel :: LogLevel -> Text
showLevel (LevelOther Text
level) = Text -> Text
T.toUpper Text
level
showLevel LogLevel
level = Text -> Text
T.toUpper (Text -> Text) -> (LogLevel -> Text) -> LogLevel -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.drop Int
5 (Text -> Text) -> (LogLevel -> Text) -> LogLevel -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogLevel -> Text
forall a b. (Show a, IsString b) => a -> b
showt (LogLevel -> Text) -> LogLevel -> Text
forall a b. (a -> b) -> a -> b
$ LogLevel
level


{- |
  Log messages to stdout. This is very bare bones. It only logs the
  message itself with no other information. It is meant to be used in
  conjunction with some of the other combinators, like `withLevel`.
-}
stdoutLogging :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
stdoutLogging :: Loc -> Text -> LogLevel -> LogStr -> IO ()
stdoutLogging = Handle -> Loc -> Text -> LogLevel -> LogStr -> IO ()
fdLogging Handle
stdout


{- | Like 'stdoutLogging', but log to a file handle. -}
fdLogging :: Handle -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
fdLogging :: Handle -> Loc -> Text -> LogLevel -> LogStr -> IO ()
fdLogging Handle
fd Loc
_ Text
_ LogLevel
_ LogStr
msg = do
  Handle -> ByteString -> IO ()
BS8.hPutStr Handle
fd (LogStr -> ByteString
fromLogStr LogStr
msg ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n")
  Handle -> IO ()
hFlush Handle
fd


{- | The standard logging for most OM programs. -}
standardLogging
  :: LogLevel
  -> Loc
  -> LogSource
  -> LogLevel
  -> LogStr
  -> IO ()
standardLogging :: LogLevel -> Loc -> Text -> LogLevel -> LogStr -> IO ()
standardLogging LogLevel
logLevel =
  LogLevel
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Loc
-> Text
-> LogLevel
-> LogStr
-> IO ()
withStandardFormat LogLevel
logLevel Loc -> Text -> LogLevel -> LogStr -> IO ()
stdoutLogging


{- |
  Log to the indicated destination, applying the "standard" filters
  and formats.
-}
withStandardFormat
  :: LogLevel {- ^ The minimum log level that will be logged. -}
  -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) {- ^ The base logger. -}
  -> Loc
  -> LogSource
  -> LogLevel
  -> LogStr
  -> IO ()
withStandardFormat :: LogLevel
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Loc
-> Text
-> LogLevel
-> LogStr
-> IO ()
withStandardFormat LogLevel
logLevel =
  (Loc -> Text -> LogLevel -> LogStr -> Bool)
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Loc
-> Text
-> LogLevel
-> LogStr
-> IO ()
filterLogging (LogLevel -> Loc -> Text -> LogLevel -> LogStr -> Bool
levelFilter LogLevel
logLevel)
  ((Loc -> Text -> LogLevel -> LogStr -> IO ())
 -> Loc -> Text -> LogLevel -> LogStr -> IO ())
-> ((Loc -> Text -> LogLevel -> LogStr -> IO ())
    -> Loc -> Text -> LogLevel -> LogStr -> IO ())
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Loc
-> Text
-> LogLevel
-> LogStr
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogStr
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Loc
-> Text
-> LogLevel
-> LogStr
-> IO ()
withPrefix LogStr
": "
  ((Loc -> Text -> LogLevel -> LogStr -> IO ())
 -> Loc -> Text -> LogLevel -> LogStr -> IO ())
-> ((Loc -> Text -> LogLevel -> LogStr -> IO ())
    -> Loc -> Text -> LogLevel -> LogStr -> IO ())
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Loc
-> Text
-> LogLevel
-> LogStr
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Loc -> Text -> LogLevel -> LogStr -> IO ()
withThread
  ((Loc -> Text -> LogLevel -> LogStr -> IO ())
 -> Loc -> Text -> LogLevel -> LogStr -> IO ())
-> ((Loc -> Text -> LogLevel -> LogStr -> IO ())
    -> Loc -> Text -> LogLevel -> LogStr -> IO ())
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Loc
-> Text
-> LogLevel
-> LogStr
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Loc -> Text -> LogLevel -> LogStr -> IO ()
withPackage
  ((Loc -> Text -> LogLevel -> LogStr -> IO ())
 -> Loc -> Text -> LogLevel -> LogStr -> IO ())
-> ((Loc -> Text -> LogLevel -> LogStr -> IO ())
    -> Loc -> Text -> LogLevel -> LogStr -> IO ())
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Loc
-> Text
-> LogLevel
-> LogStr
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Loc -> Text -> LogLevel -> LogStr -> IO ()
withLevel
  ((Loc -> Text -> LogLevel -> LogStr -> IO ())
 -> Loc -> Text -> LogLevel -> LogStr -> IO ())
-> ((Loc -> Text -> LogLevel -> LogStr -> IO ())
    -> Loc -> Text -> LogLevel -> LogStr -> IO ())
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Loc
-> Text
-> LogLevel
-> LogStr
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> Loc -> Text -> LogLevel -> LogStr -> IO ()
withTime


{- | A FromJSON instance to figure out the logging level. -}
newtype JSONLevel = JSONLevel {
    JSONLevel -> LogLevel
unJSONLevel :: LogLevel
  }
instance FromJSON JSONLevel where
  parseJSON :: Value -> Parser JSONLevel
parseJSON (String Text
str) =
    JSONLevel -> Parser JSONLevel
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (LogLevel -> JSONLevel
JSONLevel (Text -> LogLevel
parseLevel Text
str))
  parseJSON Value
v =
    String -> Parser JSONLevel
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser JSONLevel) -> String -> Parser JSONLevel
forall a b. (a -> b) -> a -> b
$ String
"Can't parse logging level from: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
v


{- | Parse a logging level from a string. -}
parseLevel :: Text -> LogLevel
parseLevel :: Text -> LogLevel
parseLevel Text
"DEBUG" = LogLevel
LevelDebug
parseLevel Text
"INFO" = LogLevel
LevelInfo
parseLevel Text
"WARN" = LogLevel
LevelWarn
parseLevel Text
"ERROR" = LogLevel
LevelError
parseLevel Text
other = Text -> LogLevel
LevelOther Text
other