{-# LANGUAGE RecordWildCards #-}
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
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)
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)
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