-- | Basic data types used throughout the package.
module Log.Data (
    LogLevel(..)
  , showLogLevel
  , readLogLevel
  , readLogLevelEither
  , LogMessage(..)
  , showLogMessage
  , defaultLogLevel
  ) 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

-- | Available log levels.
-- Note that ordering in this definintion determines what the maximum log level is.
-- See 'Log.Monad.leMaxLogLevel'.
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)

-- | This function is partial.
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"

-- | The default log level. Returns `LogInfo`.
defaultLogLevel :: LogLevel
defaultLogLevel :: LogLevel
defaultLogLevel = LogLevel
LogInfo

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` ())

-- | Represents message to be logged.
data LogMessage = LogMessage {
  -- | Component of an application.
  LogMessage -> Text
lmComponent :: !T.Text
  -- | Application log domain.
, LogMessage -> [Text]
lmDomain    :: ![T.Text]
  -- | Time of the logged event.
, LogMessage -> UTCTime
lmTime      :: !UTCTime
  -- | Log level.
, LogMessage -> LogLevel
lmLevel     :: !LogLevel
  -- | Message to be logged.
, LogMessage -> Text
lmMessage   :: !T.Text
  -- | Additional data associated with the message.
, 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)

-- | Render a 'LogMessage' to 'Text'.
showLogMessage :: Maybe UTCTime -- ^ The time that message was added to the log.
               -> LogMessage    -- ^ The actual message.
               -> 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
    -- to suppress warnings
    (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