{-# LANGUAGE RecordWildCards #-}
-- | This module contains instances of Binary type class for
-- data types defined in the heavy-logger package.
--
module System.Log.Heavy.Instances.Binary where

import Control.Applicative
import Control.Monad
import Data.Maybe
import Data.Binary
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as B
import Data.Text.Format.Heavy
import System.Log.Heavy
import System.Posix.Syslog
import Language.Haskell.TH.Syntax (Loc (..))

allVariables :: ClosedVarContainer c => c -> [(TL.Text, TL.Text)]
allVariables :: c -> [(Text, Text)]
allVariables c
c = (Text -> Maybe (Text, Text)) -> [Text] -> [(Text, Text)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe (Text, Text)
go (c -> [Text]
forall c. ClosedVarContainer c => c -> [Text]
allVarNames c
c)
  where
    go :: Text -> Maybe (Text, Text)
go Text
name =
      case Text -> c -> Maybe Variable
forall c. VarContainer c => Text -> c -> Maybe Variable
lookupVar Text
name c
c of
        Maybe Variable
Nothing -> Maybe (Text, Text)
forall a. Maybe a
Nothing
        Just Variable
var -> case VarFormat -> Variable -> Either String Builder
formatAnyVar VarFormat
forall a. Maybe a
Nothing Variable
var of
                      Left String
_ -> Maybe (Text, Text)
forall a. Maybe a
Nothing
                      Right Builder
val -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
name, Builder -> Text
B.toLazyText Builder
val)

getTextVariables :: Get [(TL.Text, TL.Text)]
getTextVariables :: Get [(Text, Text)]
getTextVariables = Get [(Text, Text)]
forall t. Binary t => Get t
get

instance Binary Priority where
  put :: Priority -> Put
put Priority
p = Int -> Put
forall t. Binary t => t -> Put
put (Priority -> Int
forall a. Enum a => a -> Int
fromEnum Priority
p)

  get :: Get Priority
get = Int -> Priority
forall a. Enum a => Int -> a
toEnum (Int -> Priority) -> Get Int -> Get Priority
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int
forall t. Binary t => Get t
get

instance Binary Level where
  put :: Level -> Put
put Level
l = do
    Text -> Put
forall t. Binary t => t -> Put
put (Level -> Text
levelName Level
l)
    Int -> Put
forall t. Binary t => t -> Put
put (Level -> Int
levelInt Level
l)
    Priority -> Put
forall t. Binary t => t -> Put
put (Level -> Priority
levelToPriority Level
l)

  get :: Get Level
get = Text -> Int -> Priority -> Level
Level
    (Text -> Int -> Priority -> Level)
-> Get Text -> Get (Int -> Priority -> Level)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Text
forall t. Binary t => Get t
get
    Get (Int -> Priority -> Level)
-> Get Int -> Get (Priority -> Level)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Int
forall t. Binary t => Get t
get
    Get (Priority -> Level) -> Get Priority -> Get Level
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Priority
forall t. Binary t => Get t
get

instance Binary Loc where
  put :: Loc -> Put
put Loc
l = do
    String -> Put
forall t. Binary t => t -> Put
put (Loc -> String
loc_filename Loc
l)
    String -> Put
forall t. Binary t => t -> Put
put (Loc -> String
loc_package Loc
l)
    String -> Put
forall t. Binary t => t -> Put
put (Loc -> String
loc_module Loc
l)
    CharPos -> Put
forall t. Binary t => t -> Put
put (Loc -> CharPos
loc_start Loc
l)
    CharPos -> Put
forall t. Binary t => t -> Put
put (Loc -> CharPos
loc_end Loc
l)

  get :: Get Loc
get = String -> String -> String -> CharPos -> CharPos -> Loc
Loc
    (String -> String -> String -> CharPos -> CharPos -> Loc)
-> Get String
-> Get (String -> String -> CharPos -> CharPos -> Loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get String
forall t. Binary t => Get t
get
    Get (String -> String -> CharPos -> CharPos -> Loc)
-> Get String -> Get (String -> CharPos -> CharPos -> Loc)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get String
forall t. Binary t => Get t
get
    Get (String -> CharPos -> CharPos -> Loc)
-> Get String -> Get (CharPos -> CharPos -> Loc)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get String
forall t. Binary t => Get t
get
    Get (CharPos -> CharPos -> Loc)
-> Get CharPos -> Get (CharPos -> Loc)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get CharPos
forall t. Binary t => Get t
get
    Get (CharPos -> Loc) -> Get CharPos -> Get Loc
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get CharPos
forall t. Binary t => Get t
get

instance Binary LogContextFilter where
  put :: LogContextFilter -> Put
put LogContextFilter
f = do
    Maybe LogFilter -> Put
forall t. Binary t => t -> Put
put (LogContextFilter -> Maybe LogFilter
setInclude LogContextFilter
f)
    Maybe LogFilter -> Put
forall t. Binary t => t -> Put
put (LogContextFilter -> Maybe LogFilter
setExclude LogContextFilter
f)

  get :: Get LogContextFilter
get = Maybe LogFilter -> Maybe LogFilter -> LogContextFilter
LogContextFilter
    (Maybe LogFilter -> Maybe LogFilter -> LogContextFilter)
-> Get (Maybe LogFilter)
-> Get (Maybe LogFilter -> LogContextFilter)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (Maybe LogFilter)
forall t. Binary t => Get t
get
    Get (Maybe LogFilter -> LogContextFilter)
-> Get (Maybe LogFilter) -> Get LogContextFilter
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (Maybe LogFilter)
forall t. Binary t => Get t
get

-- | Serialize Variable with default format
putVariableNoformat :: Variable -> Put 
putVariableNoformat :: Variable -> Put
putVariableNoformat Variable
var =
  case VarFormat -> Variable -> Either String Builder
formatAnyVar VarFormat
forall a. Maybe a
Nothing Variable
var of
    Left String
err -> String -> Put
forall a. HasCallStack => String -> a
error String
err
    Right Builder
val -> Text -> Put
forall t. Binary t => t -> Put
put (Builder -> Text
B.toLazyText Builder
val)

-- | Deserialize Variable with default format
getVariableNoformat :: Get Variable
getVariableNoformat :: Get Variable
getVariableNoformat = do
  Text
text <- Get Text
forall t. Binary t => Get t
get
  Variable -> Get Variable
forall (m :: * -> *) a. Monad m => a -> m a
return (Variable -> Get Variable) -> Variable -> Get Variable
forall a b. (a -> b) -> a -> b
$ Text -> Variable
forall a. Formatable a => a -> Variable
Variable (Text
text :: TL.Text)

instance Binary LogContextFrame where
  put :: LogContextFrame -> Put
put LogContextFrame
f  = do
    Int -> Put
forall t. Binary t => t -> Put
put ([(Text, Variable)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(Text, Variable)] -> Int) -> [(Text, Variable)] -> Int
forall a b. (a -> b) -> a -> b
$ LogContextFrame -> [(Text, Variable)]
lcfVariables LogContextFrame
f)
    [(Text, Variable)] -> ((Text, Variable) -> Put) -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (LogContextFrame -> [(Text, Variable)]
lcfVariables LogContextFrame
f) (((Text, Variable) -> Put) -> Put)
-> ((Text, Variable) -> Put) -> Put
forall a b. (a -> b) -> a -> b
$ \(Text
name, Variable
var) -> do
      Text -> Put
forall t. Binary t => t -> Put
put Text
name
      Variable -> Put
putVariableNoformat Variable
var
    LogContextFilter -> Put
forall t. Binary t => t -> Put
put (LogContextFrame -> LogContextFilter
lcfFilter LogContextFrame
f)

  get :: Get LogContextFrame
get = do
    Int
n <- Get Int
forall t. Binary t => Get t
get :: Get Int
    [(Text, Variable)]
vars <- Int -> Get (Text, Variable) -> Get [(Text, Variable)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Get (Text, Variable) -> Get [(Text, Variable)])
-> Get (Text, Variable) -> Get [(Text, Variable)]
forall a b. (a -> b) -> a -> b
$ do
              Text
name <- Get Text
forall t. Binary t => Get t
get
              Variable
val <- Get Variable
getVariableNoformat
              (Text, Variable) -> Get (Text, Variable)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
name, Variable
val)
    LogContextFilter
fltr <- Get LogContextFilter
forall t. Binary t => Get t
get
    LogContextFrame -> Get LogContextFrame
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Text, Variable)] -> LogContextFilter -> LogContextFrame
LogContextFrame [(Text, Variable)]
vars LogContextFilter
fltr)

-- | Please note: this implementation is limited:
--
--  * It stores Variables as their Text representation
--
--  * It does not take care of correct storing/restoring variable formats
--
--  * When deserializing, it always uses @[(Text, Text)]@ as variables container.
--
instance Binary LogMessage where
  put :: LogMessage -> Put
put (LogMessage {vars
LogSource
[LogContextFrame]
Text
Level
Loc
lmLevel :: LogMessage -> Level
lmSource :: LogMessage -> LogSource
lmLocation :: LogMessage -> Loc
lmFormatString :: LogMessage -> Text
lmFormatVars :: ()
lmContext :: LogMessage -> [LogContextFrame]
lmContext :: [LogContextFrame]
lmFormatVars :: vars
lmFormatString :: Text
lmLocation :: Loc
lmSource :: LogSource
lmLevel :: Level
..}) = do
    Level -> Put
forall t. Binary t => t -> Put
put Level
lmLevel
    LogSource -> Put
forall t. Binary t => t -> Put
put LogSource
lmSource 
    Loc -> Put
forall t. Binary t => t -> Put
put Loc
lmLocation 
    Text -> Put
forall t. Binary t => t -> Put
put Text
lmFormatString 
    [(Text, Text)] -> Put
forall t. Binary t => t -> Put
put (vars -> [(Text, Text)]
forall c. ClosedVarContainer c => c -> [(Text, Text)]
allVariables vars
lmFormatVars)
    [LogContextFrame] -> Put
forall t. Binary t => t -> Put
put [LogContextFrame]
lmContext

  get :: Get LogMessage
get = Level
-> LogSource
-> Loc
-> Text
-> [(Text, Text)]
-> [LogContextFrame]
-> LogMessage
forall vars.
ClosedVarContainer vars =>
Level
-> LogSource
-> Loc
-> Text
-> vars
-> [LogContextFrame]
-> LogMessage
LogMessage
    (Level
 -> LogSource
 -> Loc
 -> Text
 -> [(Text, Text)]
 -> [LogContextFrame]
 -> LogMessage)
-> Get Level
-> Get
     (LogSource
      -> Loc
      -> Text
      -> [(Text, Text)]
      -> [LogContextFrame]
      -> LogMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Level
forall t. Binary t => Get t
get
    Get
  (LogSource
   -> Loc
   -> Text
   -> [(Text, Text)]
   -> [LogContextFrame]
   -> LogMessage)
-> Get LogSource
-> Get
     (Loc -> Text -> [(Text, Text)] -> [LogContextFrame] -> LogMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get LogSource
forall t. Binary t => Get t
get
    Get
  (Loc -> Text -> [(Text, Text)] -> [LogContextFrame] -> LogMessage)
-> Get Loc
-> Get (Text -> [(Text, Text)] -> [LogContextFrame] -> LogMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Loc
forall t. Binary t => Get t
get
    Get (Text -> [(Text, Text)] -> [LogContextFrame] -> LogMessage)
-> Get Text
-> Get ([(Text, Text)] -> [LogContextFrame] -> LogMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Text
forall t. Binary t => Get t
get
    Get ([(Text, Text)] -> [LogContextFrame] -> LogMessage)
-> Get [(Text, Text)] -> Get ([LogContextFrame] -> LogMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [(Text, Text)]
getTextVariables
    Get ([LogContextFrame] -> LogMessage)
-> Get [LogContextFrame] -> Get LogMessage
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [LogContextFrame]
forall t. Binary t => Get t
get