module Log.Data (
LogLevel(..)
, showLogLevel
, readLogLevel
, LogMessage(..)
, showLogMessage
) where
import Control.DeepSeq
import Control.Applicative
import Data.Aeson
import Data.Aeson.Encode.Pretty
import Data.Aeson.Types
import Data.ByteString.Lazy (toStrict)
import Data.Time
import Prelude
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Monoid as Monoid
data LogLevel = LogAttention | LogInfo | LogTrace
deriving (LogLevel
LogLevel -> LogLevel -> Bounded LogLevel
forall a. a -> a -> Bounded a
maxBound :: LogLevel
$cmaxBound :: LogLevel
minBound :: LogLevel
$cminBound :: LogLevel
Bounded, LogLevel -> LogLevel -> Bool
(LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool) -> Eq LogLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogLevel -> LogLevel -> Bool
$c/= :: LogLevel -> LogLevel -> Bool
== :: LogLevel -> LogLevel -> Bool
$c== :: LogLevel -> LogLevel -> Bool
Eq, Eq LogLevel
Eq LogLevel
-> (LogLevel -> LogLevel -> Ordering)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> LogLevel)
-> (LogLevel -> LogLevel -> LogLevel)
-> Ord LogLevel
LogLevel -> LogLevel -> Bool
LogLevel -> LogLevel -> Ordering
LogLevel -> LogLevel -> LogLevel
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LogLevel -> LogLevel -> LogLevel
$cmin :: LogLevel -> LogLevel -> LogLevel
max :: LogLevel -> LogLevel -> LogLevel
$cmax :: LogLevel -> LogLevel -> LogLevel
>= :: LogLevel -> LogLevel -> Bool
$c>= :: LogLevel -> LogLevel -> Bool
> :: LogLevel -> LogLevel -> Bool
$c> :: LogLevel -> LogLevel -> Bool
<= :: LogLevel -> LogLevel -> Bool
$c<= :: LogLevel -> LogLevel -> Bool
< :: LogLevel -> LogLevel -> Bool
$c< :: LogLevel -> LogLevel -> Bool
compare :: LogLevel -> LogLevel -> Ordering
$ccompare :: LogLevel -> LogLevel -> Ordering
$cp1Ord :: Eq LogLevel
Ord, Int -> LogLevel -> ShowS
[LogLevel] -> ShowS
LogLevel -> String
(Int -> LogLevel -> ShowS)
-> (LogLevel -> String) -> ([LogLevel] -> ShowS) -> Show LogLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogLevel] -> ShowS
$cshowList :: [LogLevel] -> ShowS
show :: LogLevel -> String
$cshow :: LogLevel -> String
showsPrec :: Int -> LogLevel -> ShowS
$cshowsPrec :: Int -> LogLevel -> ShowS
Show)
readLogLevel :: T.Text -> LogLevel
readLogLevel :: Text -> LogLevel
readLogLevel = (String -> LogLevel)
-> (LogLevel -> LogLevel) -> Either String LogLevel -> LogLevel
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> LogLevel
forall a. HasCallStack => String -> a
error LogLevel -> LogLevel
forall a. a -> a
id (Either String LogLevel -> LogLevel)
-> (Text -> Either String LogLevel) -> Text -> LogLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String LogLevel
readLogLevelEither
{-# INLINE readLogLevel #-}
readLogLevelEither :: T.Text -> Either String LogLevel
readLogLevelEither :: Text -> Either String LogLevel
readLogLevelEither Text
"attention" = LogLevel -> Either String LogLevel
forall a b. b -> Either a b
Right LogLevel
LogAttention
readLogLevelEither Text
"info" = LogLevel -> Either String LogLevel
forall a b. b -> Either a b
Right LogLevel
LogInfo
readLogLevelEither Text
"trace" = LogLevel -> Either String LogLevel
forall a b. b -> Either a b
Right LogLevel
LogTrace
readLogLevelEither Text
level = String -> Either String LogLevel
forall a b. a -> Either a b
Left (String -> Either String LogLevel)
-> String -> Either String LogLevel
forall a b. (a -> b) -> a -> b
$ String
"readLogLevel: unknown level: "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
level
showLogLevel :: LogLevel -> T.Text
showLogLevel :: LogLevel -> Text
showLogLevel LogLevel
LogAttention = Text
"attention"
showLogLevel LogLevel
LogInfo = Text
"info"
showLogLevel LogLevel
LogTrace = Text
"trace"
instance ToJSON LogLevel where
toJSON :: LogLevel -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (LogLevel -> Text) -> LogLevel -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogLevel -> Text
showLogLevel
toEncoding :: LogLevel -> Encoding
toEncoding = Text -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding (Text -> Encoding) -> (LogLevel -> Text) -> LogLevel -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogLevel -> Text
showLogLevel
instance FromJSON LogLevel where
parseJSON :: Value -> Parser LogLevel
parseJSON = String -> (Text -> Parser LogLevel) -> Value -> Parser LogLevel
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"LogLevel" ((Text -> Parser LogLevel) -> Value -> Parser LogLevel)
-> (Text -> Parser LogLevel) -> Value -> Parser LogLevel
forall a b. (a -> b) -> a -> b
$
(String -> Parser LogLevel)
-> (LogLevel -> Parser LogLevel)
-> Either String LogLevel
-> Parser LogLevel
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser LogLevel
forall (m :: * -> *) a. MonadFail m => String -> m a
fail LogLevel -> Parser LogLevel
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String LogLevel -> Parser LogLevel)
-> (Text -> Either String LogLevel) -> Text -> Parser LogLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String LogLevel
readLogLevelEither
instance NFData LogLevel where
rnf :: LogLevel -> ()
rnf = (LogLevel -> () -> ()
`seq` ())
data LogMessage = LogMessage {
LogMessage -> Text
lmComponent :: !T.Text
, LogMessage -> [Text]
lmDomain :: ![T.Text]
, LogMessage -> UTCTime
lmTime :: !UTCTime
, LogMessage -> LogLevel
lmLevel :: !LogLevel
, LogMessage -> Text
lmMessage :: !T.Text
, LogMessage -> Value
lmData :: !Value
} deriving (LogMessage -> LogMessage -> Bool
(LogMessage -> LogMessage -> Bool)
-> (LogMessage -> LogMessage -> Bool) -> Eq LogMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogMessage -> LogMessage -> Bool
$c/= :: LogMessage -> LogMessage -> Bool
== :: LogMessage -> LogMessage -> Bool
$c== :: LogMessage -> LogMessage -> Bool
Eq, Int -> LogMessage -> ShowS
[LogMessage] -> ShowS
LogMessage -> String
(Int -> LogMessage -> ShowS)
-> (LogMessage -> String)
-> ([LogMessage] -> ShowS)
-> Show LogMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogMessage] -> ShowS
$cshowList :: [LogMessage] -> ShowS
show :: LogMessage -> String
$cshow :: LogMessage -> String
showsPrec :: Int -> LogMessage -> ShowS
$cshowsPrec :: Int -> LogMessage -> ShowS
Show)
showLogMessage :: Maybe UTCTime
-> LogMessage
-> T.Text
showLogMessage :: Maybe UTCTime -> LogMessage -> Text
showLogMessage Maybe UTCTime
mInsertionTime LogMessage{[Text]
Text
UTCTime
Value
LogLevel
lmData :: Value
lmMessage :: Text
lmLevel :: LogLevel
lmTime :: UTCTime
lmDomain :: [Text]
lmComponent :: Text
lmData :: LogMessage -> Value
lmMessage :: LogMessage -> Text
lmLevel :: LogMessage -> LogLevel
lmTime :: LogMessage -> UTCTime
lmDomain :: LogMessage -> [Text]
lmComponent :: LogMessage -> Text
..} = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [
String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y-%m-%d %H:%M:%S" UTCTime
lmTime
, case Maybe UTCTime
mInsertionTime of
Maybe UTCTime
Nothing -> Text
" "
Just UTCTime
it -> String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
" (%H:%M:%S) " UTCTime
it
, Text -> Text
T.toUpper (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ LogLevel -> Text
showLogLevel LogLevel
lmLevel
, Text
" "
, Text -> [Text] -> Text
T.intercalate Text
"/" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text
lmComponent Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
lmDomain
, Text
": "
, Text
lmMessage
] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ if Value
lmData Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
emptyObject
then []
else [Text
" ", Value -> Text
textifyData Value
lmData]
where
textifyData :: Value -> T.Text
textifyData :: Value -> Text
textifyData = ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> (Value -> ByteString) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict (ByteString -> ByteString)
-> (Value -> ByteString) -> Value -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Value -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
encodePretty' Config
defConfig {
confIndent :: Indent
confIndent = Int -> Indent
Spaces Int
2
}
instance ToJSON LogMessage where
toJSON :: LogMessage -> Value
toJSON LogMessage{[Text]
Text
UTCTime
Value
LogLevel
lmData :: Value
lmMessage :: Text
lmLevel :: LogLevel
lmTime :: UTCTime
lmDomain :: [Text]
lmComponent :: Text
lmData :: LogMessage -> Value
lmMessage :: LogMessage -> Text
lmLevel :: LogMessage -> LogLevel
lmTime :: LogMessage -> UTCTime
lmDomain :: LogMessage -> [Text]
lmComponent :: LogMessage -> Text
..} = [Pair] -> Value
object [
Text
"component" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
lmComponent
, Text
"domain" Text -> [Text] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Text]
lmDomain
, Text
"time" Text -> UTCTime -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= UTCTime
lmTime
, Text
"level" Text -> LogLevel -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= LogLevel
lmLevel
, Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
lmMessage
, Text
"data" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value
lmData
]
toEncoding :: LogMessage -> Encoding
toEncoding LogMessage{[Text]
Text
UTCTime
Value
LogLevel
lmData :: Value
lmMessage :: Text
lmLevel :: LogLevel
lmTime :: UTCTime
lmDomain :: [Text]
lmComponent :: Text
lmData :: LogMessage -> Value
lmMessage :: LogMessage -> Text
lmLevel :: LogMessage -> LogLevel
lmTime :: LogMessage -> UTCTime
lmDomain :: LogMessage -> [Text]
lmComponent :: LogMessage -> Text
..} = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ [Series] -> Series
forall a. Monoid a => [a] -> a
Monoid.mconcat [
Text
"component" Text -> Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
lmComponent
, Text
"domain" Text -> [Text] -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Text]
lmDomain
, Text
"time" Text -> UTCTime -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= UTCTime
lmTime
, Text
"level" Text -> LogLevel -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= LogLevel
lmLevel
, Text
"message" Text -> Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
lmMessage
, Text
"data" Text -> Value -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value
lmData
]
instance FromJSON LogMessage where
parseJSON :: Value -> Parser LogMessage
parseJSON = String
-> (Object -> Parser LogMessage) -> Value -> Parser LogMessage
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"LogMessage" ((Object -> Parser LogMessage) -> Value -> Parser LogMessage)
-> (Object -> Parser LogMessage) -> Value -> Parser LogMessage
forall a b. (a -> b) -> a -> b
$ \Object
obj -> Text
-> [Text] -> UTCTime -> LogLevel -> Text -> Value -> LogMessage
LogMessage
(Text
-> [Text] -> UTCTime -> LogLevel -> Text -> Value -> LogMessage)
-> Parser Text
-> Parser
([Text] -> UTCTime -> LogLevel -> Text -> Value -> LogMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Control.Applicative.<$> Object
obj Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"component"
Parser
([Text] -> UTCTime -> LogLevel -> Text -> Value -> LogMessage)
-> Parser [Text]
-> Parser (UTCTime -> LogLevel -> Text -> Value -> LogMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> Text -> Parser [Text]
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"domain"
Parser (UTCTime -> LogLevel -> Text -> Value -> LogMessage)
-> Parser UTCTime
-> Parser (LogLevel -> Text -> Value -> LogMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> Text -> Parser UTCTime
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"time"
Parser (LogLevel -> Text -> Value -> LogMessage)
-> Parser LogLevel -> Parser (Text -> Value -> LogMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> Text -> Parser LogLevel
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"level"
Parser (Text -> Value -> LogMessage)
-> Parser Text -> Parser (Value -> LogMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"message"
Parser (Value -> LogMessage) -> Parser Value -> Parser LogMessage
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"data"
instance NFData LogMessage where
rnf :: LogMessage -> ()
rnf LogMessage{[Text]
Text
UTCTime
Value
LogLevel
lmData :: Value
lmMessage :: Text
lmLevel :: LogLevel
lmTime :: UTCTime
lmDomain :: [Text]
lmComponent :: Text
lmData :: LogMessage -> Value
lmMessage :: LogMessage -> Text
lmLevel :: LogMessage -> LogLevel
lmTime :: LogMessage -> UTCTime
lmDomain :: LogMessage -> [Text]
lmComponent :: LogMessage -> Text
..} = Text -> ()
forall a. NFData a => a -> ()
rnf Text
lmComponent
() -> () -> ()
`seq` [Text] -> ()
forall a. NFData a => a -> ()
rnf [Text]
lmDomain
() -> () -> ()
`seq` UTCTime -> ()
forall a. NFData a => a -> ()
rnf UTCTime
lmTime
() -> () -> ()
`seq` LogLevel -> ()
forall a. NFData a => a -> ()
rnf LogLevel
lmLevel
() -> () -> ()
`seq` Text -> ()
forall a. NFData a => a -> ()
rnf Text
lmMessage
() -> () -> ()
`seq` Value -> ()
forall a. NFData a => a -> ()
rnf Value
lmData