{-# LANGUAGE OverloadedStrings #-}
module OM.Logging (
standardLogging,
withStandardFormat,
withTime,
withThread,
withLevel,
withPrefix,
withPackage,
filterLogging,
levelFilter,
teeLogging,
stdoutLogging,
fdLogging,
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
teeLogging
:: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> 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
filterLogging
:: (Loc -> LogSource -> LogLevel -> LogStr -> Bool)
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> 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 :: 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
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)
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)
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
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)
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)
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)
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
"]"
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
stdoutLogging :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
stdoutLogging :: Loc -> Text -> LogLevel -> LogStr -> IO ()
stdoutLogging = Handle -> Loc -> Text -> LogLevel -> LogStr -> IO ()
fdLogging Handle
stdout
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
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
withStandardFormat
:: LogLevel
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> 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
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
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