{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable   #-}
{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE RecordWildCards      #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ConstrainedClassMethods #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Distributed.Process.Extras.SystemLog
-- Copyright   :  (c) Tim Watson 2013 - 2017
-- License     :  BSD3 (see the file LICENSE)
--
-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable (requires concurrency)
--
-- This module provides a general purpose logging facility, implemented as a
-- distributed-process /Management Agent/. To start the logging agent on a
-- running node, evaluate 'systemLog' with the relevant expressions to handle
-- logging textual messages, a cleanup operation (if required), initial log
-- level and a formatting expression.
--
-- We export a working example in the form of 'systemLogFile', which logs
-- to a text file using buffered I/O. Its implementation is very simple, and
-- should serve as a demonstration of how to use the API:
--
-- > systemLogFile :: FilePath -> LogLevel -> LogFormat -> Process ProcessId
-- > systemLogFile path lvl fmt = do
-- >   h <- liftIO $ openFile path AppendMode
-- >   liftIO $ hSetBuffering h LineBuffering
-- >   systemLog (liftIO . hPutStrLn h) (liftIO (hClose h)) lvl fmt
--
-----------------------------------------------------------------------------

-- TODO - REWRITE THIS WITHOUT USING THE MX API, SINCE THAT's POINTLESS>>>>>>>.

module Control.Distributed.Process.Extras.SystemLog
  ( -- * Types exposed by this module
    LogLevel(..)
  , LogFormat
  , LogClient
  , LogChan
  , LogText
  , ToLog(..)
  , Logger(..)
    -- * Mx Agent Configuration / Startup
  , mxLogId
  , systemLog
  , client
  , logChannel
  , addFormatter
    -- * systemLogFile
  , systemLogFile
    -- * Logging Messages
  , report
  , debug
  , info
  , notice
  , warning
  , error
  , critical
  , alert
  , emergency
  , sendLog
  ) where

import Control.DeepSeq (NFData(..))
import Control.Distributed.Process hiding (catch)
import Control.Distributed.Process.Management
  ( MxEvent(MxConnected, MxDisconnected, MxLog, MxUser)
  , MxAgentId(..)
  , mxAgentWithFinalize
  , mxSink
  , mxReady
  , mxReceive
  , liftMX
  , mxGetLocal
  , mxSetLocal
  , mxUpdateLocal
  , mxNotify
  )
import Control.Distributed.Process.Extras
  ( Resolvable(..)
  , Routable(..)
  , Addressable
  )
import Control.Distributed.Process.Serializable
import Control.Exception (SomeException)
import Control.Monad.Catch (catch)
import Data.Binary
import Data.Typeable (Typeable)
import GHC.Generics

import Prelude hiding (error, Read)

import System.IO
  ( IOMode(AppendMode)
  , BufferMode(..)
  , openFile
  , hClose
  , hPutStrLn
  , hSetBuffering
  )
import Text.Read (Read)

data LogLevel =
    Debug
  | Info
  | Notice
  | Warning
  | Error
  | Critical
  | Alert
  | Emergency
  deriving (Typeable, (forall x. LogLevel -> Rep LogLevel x)
-> (forall x. Rep LogLevel x -> LogLevel) -> Generic LogLevel
forall x. Rep LogLevel x -> LogLevel
forall x. LogLevel -> Rep LogLevel x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LogLevel -> Rep LogLevel x
from :: forall x. LogLevel -> Rep LogLevel x
$cto :: forall x. Rep LogLevel x -> LogLevel
to :: forall x. Rep LogLevel x -> LogLevel
Generic, LogLevel -> LogLevel -> Bool
(LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool) -> Eq LogLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LogLevel -> LogLevel -> Bool
== :: LogLevel -> LogLevel -> Bool
$c/= :: LogLevel -> LogLevel -> Bool
/= :: LogLevel -> LogLevel -> Bool
Eq,
            ReadPrec [LogLevel]
ReadPrec LogLevel
Int -> ReadS LogLevel
ReadS [LogLevel]
(Int -> ReadS LogLevel)
-> ReadS [LogLevel]
-> ReadPrec LogLevel
-> ReadPrec [LogLevel]
-> Read LogLevel
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS LogLevel
readsPrec :: Int -> ReadS LogLevel
$creadList :: ReadS [LogLevel]
readList :: ReadS [LogLevel]
$creadPrec :: ReadPrec LogLevel
readPrec :: ReadPrec LogLevel
$creadListPrec :: ReadPrec [LogLevel]
readListPrec :: ReadPrec [LogLevel]
Read, 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
$cshowsPrec :: Int -> LogLevel -> ShowS
showsPrec :: Int -> LogLevel -> ShowS
$cshow :: LogLevel -> String
show :: LogLevel -> String
$cshowList :: [LogLevel] -> ShowS
showList :: [LogLevel] -> ShowS
Show, 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
$ccompare :: LogLevel -> LogLevel -> Ordering
compare :: LogLevel -> LogLevel -> Ordering
$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
>= :: LogLevel -> LogLevel -> Bool
$cmax :: LogLevel -> LogLevel -> LogLevel
max :: LogLevel -> LogLevel -> LogLevel
$cmin :: LogLevel -> LogLevel -> LogLevel
min :: LogLevel -> LogLevel -> LogLevel
Ord, Int -> LogLevel
LogLevel -> Int
LogLevel -> [LogLevel]
LogLevel -> LogLevel
LogLevel -> LogLevel -> [LogLevel]
LogLevel -> LogLevel -> LogLevel -> [LogLevel]
(LogLevel -> LogLevel)
-> (LogLevel -> LogLevel)
-> (Int -> LogLevel)
-> (LogLevel -> Int)
-> (LogLevel -> [LogLevel])
-> (LogLevel -> LogLevel -> [LogLevel])
-> (LogLevel -> LogLevel -> [LogLevel])
-> (LogLevel -> LogLevel -> LogLevel -> [LogLevel])
-> Enum LogLevel
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: LogLevel -> LogLevel
succ :: LogLevel -> LogLevel
$cpred :: LogLevel -> LogLevel
pred :: LogLevel -> LogLevel
$ctoEnum :: Int -> LogLevel
toEnum :: Int -> LogLevel
$cfromEnum :: LogLevel -> Int
fromEnum :: LogLevel -> Int
$cenumFrom :: LogLevel -> [LogLevel]
enumFrom :: LogLevel -> [LogLevel]
$cenumFromThen :: LogLevel -> LogLevel -> [LogLevel]
enumFromThen :: LogLevel -> LogLevel -> [LogLevel]
$cenumFromTo :: LogLevel -> LogLevel -> [LogLevel]
enumFromTo :: LogLevel -> LogLevel -> [LogLevel]
$cenumFromThenTo :: LogLevel -> LogLevel -> LogLevel -> [LogLevel]
enumFromThenTo :: LogLevel -> LogLevel -> LogLevel -> [LogLevel]
Enum)
instance Binary LogLevel where
instance NFData LogLevel where rnf :: LogLevel -> ()
rnf LogLevel
x = LogLevel
x LogLevel -> () -> ()
forall a b. a -> b -> b
`seq` ()

data SetLevel = SetLevel !LogLevel
  deriving (Typeable, (forall x. SetLevel -> Rep SetLevel x)
-> (forall x. Rep SetLevel x -> SetLevel) -> Generic SetLevel
forall x. Rep SetLevel x -> SetLevel
forall x. SetLevel -> Rep SetLevel x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SetLevel -> Rep SetLevel x
from :: forall x. SetLevel -> Rep SetLevel x
$cto :: forall x. Rep SetLevel x -> SetLevel
to :: forall x. Rep SetLevel x -> SetLevel
Generic)
instance Binary SetLevel where
instance NFData SetLevel where rnf :: SetLevel -> ()
rnf SetLevel
x = SetLevel
x SetLevel -> () -> ()
forall a b. a -> b -> b
`seq` ()

newtype AddFormatter = AddFormatter (Closure (Message -> Process (Maybe String)))
  deriving (Typeable, (forall x. AddFormatter -> Rep AddFormatter x)
-> (forall x. Rep AddFormatter x -> AddFormatter)
-> Generic AddFormatter
forall x. Rep AddFormatter x -> AddFormatter
forall x. AddFormatter -> Rep AddFormatter x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. AddFormatter -> Rep AddFormatter x
from :: forall x. AddFormatter -> Rep AddFormatter x
$cto :: forall x. Rep AddFormatter x -> AddFormatter
to :: forall x. Rep AddFormatter x -> AddFormatter
Generic, AddFormatter -> ()
(AddFormatter -> ()) -> NFData AddFormatter
forall a. (a -> ()) -> NFData a
$crnf :: AddFormatter -> ()
rnf :: AddFormatter -> ()
NFData)
instance Binary AddFormatter

data LogState =
  LogState { LogState -> String -> Process ()
output     :: !(String -> Process ())
           , LogState -> Process ()
cleanup    :: !(Process ())
           , LogState -> LogLevel
level      :: !LogLevel
           , LogState -> String -> Process String
format     :: !(String -> Process String)
           , LogState -> [Message -> Process (Maybe String)]
formatters :: ![Message -> Process (Maybe String)]
           }

data LogMessage =
    LogMessage !String  !LogLevel
  | LogData    !Message !LogLevel
  deriving (Typeable, (forall x. LogMessage -> Rep LogMessage x)
-> (forall x. Rep LogMessage x -> LogMessage) -> Generic LogMessage
forall x. Rep LogMessage x -> LogMessage
forall x. LogMessage -> Rep LogMessage x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LogMessage -> Rep LogMessage x
from :: forall x. LogMessage -> Rep LogMessage x
$cto :: forall x. Rep LogMessage x -> LogMessage
to :: forall x. Rep LogMessage x -> LogMessage
Generic, 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
$cshowsPrec :: Int -> LogMessage -> ShowS
showsPrec :: Int -> LogMessage -> ShowS
$cshow :: LogMessage -> String
show :: LogMessage -> String
$cshowList :: [LogMessage] -> ShowS
showList :: [LogMessage] -> ShowS
Show)
instance Binary LogMessage where
instance NFData LogMessage where rnf :: LogMessage -> ()
rnf LogMessage
x = LogMessage
x LogMessage -> () -> ()
forall a b. a -> b -> b
`seq` ()

type LogFormat = String -> Process String

type LogChanT = ()

newtype LogChan = LogChan LogChanT
instance Routable LogChan where
  sendTo :: forall m.
(Serializable m, Resolvable LogChan) =>
LogChan -> m -> Process ()
sendTo       LogChan
_ = m -> Process ()
forall a. Serializable a => a -> Process ()
mxNotify
  unsafeSendTo :: forall m.
(NFSerializable m, Resolvable LogChan) =>
LogChan -> m -> Process ()
unsafeSendTo LogChan
_ = m -> Process ()
forall a. Serializable a => a -> Process ()
mxNotify

type LogText = String

newtype LogClient = LogClient { LogClient -> ProcessId
agent :: ProcessId }
instance Resolvable LogClient where
  resolve :: LogClient -> Process (Maybe ProcessId)
resolve = Maybe ProcessId -> Process (Maybe ProcessId)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ProcessId -> Process (Maybe ProcessId))
-> (LogClient -> Maybe ProcessId)
-> LogClient
-> Process (Maybe ProcessId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessId -> Maybe ProcessId
forall a. a -> Maybe a
Just (ProcessId -> Maybe ProcessId)
-> (LogClient -> ProcessId) -> LogClient -> Maybe ProcessId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogClient -> ProcessId
agent
instance Routable LogClient

class ToLog m where
  toLog :: (Serializable m) => m -> Process (LogLevel -> LogMessage)
  toLog = (LogLevel -> LogMessage) -> Process (LogLevel -> LogMessage)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LogLevel -> LogMessage) -> Process (LogLevel -> LogMessage))
-> (m -> LogLevel -> LogMessage)
-> m
-> Process (LogLevel -> LogMessage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> LogLevel -> LogMessage
LogData (Message -> LogLevel -> LogMessage)
-> (m -> Message) -> m -> LogLevel -> LogMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m -> Message
forall a. Serializable a => a -> Message
unsafeWrapMessage

instance ToLog LogText where
  toLog :: (Binary String, Typeable String) =>
String -> Process (LogLevel -> LogMessage)
toLog = (LogLevel -> LogMessage) -> Process (LogLevel -> LogMessage)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LogLevel -> LogMessage) -> Process (LogLevel -> LogMessage))
-> (String -> LogLevel -> LogMessage)
-> String
-> Process (LogLevel -> LogMessage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> LogLevel -> LogMessage
LogMessage

instance ToLog Message where
  toLog :: Serializable Message => Message -> Process (LogLevel -> LogMessage)
toLog = (LogLevel -> LogMessage) -> Process (LogLevel -> LogMessage)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LogLevel -> LogMessage) -> Process (LogLevel -> LogMessage))
-> (Message -> LogLevel -> LogMessage)
-> Message
-> Process (LogLevel -> LogMessage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> LogLevel -> LogMessage
LogData

class Logger a where
  logMessage :: a -> LogMessage -> Process ()

instance Logger LogClient where
  logMessage :: LogClient -> LogMessage -> Process ()
logMessage = LogClient -> LogMessage -> Process ()
forall m.
(Serializable m, Resolvable LogClient) =>
LogClient -> m -> Process ()
forall a m.
(Routable a, Serializable m, Resolvable a) =>
a -> m -> Process ()
sendTo

instance Logger LogChan where
  logMessage :: LogChan -> LogMessage -> Process ()
logMessage LogChan
_ = LogMessage -> Process ()
forall a. Serializable a => a -> Process ()
mxNotify

logProcessName :: String
logProcessName :: String
logProcessName = String
"service.systemlog"

mxLogId :: MxAgentId
mxLogId :: MxAgentId
mxLogId = String -> MxAgentId
MxAgentId String
logProcessName

logChannel :: LogChan
logChannel :: LogChan
logChannel = () -> LogChan
LogChan ()

report :: (Logger l)
       => (l -> LogText -> Process ())
       -> l
       -> String
       -> Process ()
report :: forall l.
Logger l =>
(l -> String -> Process ()) -> l -> String -> Process ()
report l -> String -> Process ()
f l
l = l -> String -> Process ()
f l
l

client :: Process (Maybe LogClient)
client :: Process (Maybe LogClient)
client = String -> Process (Maybe ProcessId)
forall a. Resolvable a => a -> Process (Maybe ProcessId)
resolve String
logProcessName Process (Maybe ProcessId)
-> (Maybe ProcessId -> Process (Maybe LogClient))
-> Process (Maybe LogClient)
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe LogClient -> Process (Maybe LogClient)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe LogClient -> Process (Maybe LogClient))
-> (Maybe ProcessId -> Maybe LogClient)
-> Maybe ProcessId
-> Process (Maybe LogClient)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe LogClient
-> (ProcessId -> Maybe LogClient)
-> Maybe ProcessId
-> Maybe LogClient
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe LogClient
forall a. Maybe a
Nothing (LogClient -> Maybe LogClient
forall a. a -> Maybe a
Just (LogClient -> Maybe LogClient)
-> (ProcessId -> LogClient) -> ProcessId -> Maybe LogClient
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessId -> LogClient
LogClient)

debug :: (Logger l, Serializable m, ToLog m) => l -> m -> Process ()
debug :: forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> Process ()
debug l
l m
m = l -> m -> LogLevel -> Process ()
forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> LogLevel -> Process ()
sendLog l
l m
m LogLevel
Debug

info :: (Logger l, Serializable m, ToLog m) => l -> m -> Process ()
info :: forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> Process ()
info l
l m
m = l -> m -> LogLevel -> Process ()
forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> LogLevel -> Process ()
sendLog l
l m
m LogLevel
Info

notice :: (Logger l, Serializable m, ToLog m) => l -> m -> Process ()
notice :: forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> Process ()
notice l
l m
m = l -> m -> LogLevel -> Process ()
forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> LogLevel -> Process ()
sendLog l
l m
m LogLevel
Notice

warning :: (Logger l, Serializable m, ToLog m) => l -> m -> Process ()
warning :: forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> Process ()
warning l
l m
m = l -> m -> LogLevel -> Process ()
forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> LogLevel -> Process ()
sendLog l
l m
m LogLevel
Warning

error :: (Logger l, Serializable m, ToLog m) => l -> m -> Process ()
error :: forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> Process ()
error l
l m
m = l -> m -> LogLevel -> Process ()
forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> LogLevel -> Process ()
sendLog l
l m
m LogLevel
Error

critical :: (Logger l, Serializable m, ToLog m) => l -> m -> Process ()
critical :: forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> Process ()
critical l
l m
m = l -> m -> LogLevel -> Process ()
forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> LogLevel -> Process ()
sendLog l
l m
m LogLevel
Critical

alert :: (Logger l, Serializable m, ToLog m) => l -> m -> Process ()
alert :: forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> Process ()
alert l
l m
m = l -> m -> LogLevel -> Process ()
forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> LogLevel -> Process ()
sendLog l
l m
m LogLevel
Alert

emergency :: (Logger l, Serializable m, ToLog m) => l -> m -> Process ()
emergency :: forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> Process ()
emergency l
l m
m = l -> m -> LogLevel -> Process ()
forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> LogLevel -> Process ()
sendLog l
l m
m LogLevel
Emergency

sendLog :: (Logger l, Serializable m, ToLog m) => l -> m -> LogLevel -> Process ()
sendLog :: forall l m.
(Logger l, Serializable m, ToLog m) =>
l -> m -> LogLevel -> Process ()
sendLog l
a m
m LogLevel
lv = m -> Process (LogLevel -> LogMessage)
forall m.
(ToLog m, Serializable m) =>
m -> Process (LogLevel -> LogMessage)
toLog m
m Process (LogLevel -> LogMessage)
-> ((LogLevel -> LogMessage) -> Process ()) -> Process ()
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \LogLevel -> LogMessage
m' -> l -> LogMessage -> Process ()
forall a. Logger a => a -> LogMessage -> Process ()
logMessage l
a (LogMessage -> Process ()) -> LogMessage -> Process ()
forall a b. (a -> b) -> a -> b
$ LogLevel -> LogMessage
m' LogLevel
lv

addFormatter :: (Addressable r)
             => r
             -> Closure (Message -> Process (Maybe String))
             -> Process ()
addFormatter :: forall r.
Addressable r =>
r -> Closure (Message -> Process (Maybe String)) -> Process ()
addFormatter r
r Closure (Message -> Process (Maybe String))
clj = r -> AddFormatter -> Process ()
forall m. (Serializable m, Resolvable r) => r -> m -> Process ()
forall a m.
(Routable a, Serializable m, Resolvable a) =>
a -> m -> Process ()
sendTo r
r (AddFormatter -> Process ()) -> AddFormatter -> Process ()
forall a b. (a -> b) -> a -> b
$ Closure (Message -> Process (Maybe String)) -> AddFormatter
AddFormatter Closure (Message -> Process (Maybe String))
clj

-- | Start a system logger that writes to a file.
--
-- This is a /very basic/ file logging facility, that uses /regular/ buffered
-- file I/O (i.e., @System.IO.hPutStrLn@ et al) under the covers. The handle
-- is closed appropriately if/when the logging process terminates.
--
-- See @Control.Distributed.Process.Management.mxAgentWithFinalize@ for futher
-- details about management agents that use finalizers.
--
systemLogFile :: FilePath -> LogLevel -> LogFormat -> Process ProcessId
systemLogFile :: String
-> LogLevel -> (String -> Process String) -> Process ProcessId
systemLogFile String
path LogLevel
lvl String -> Process String
fmt = do
  Handle
h <- IO Handle -> Process Handle
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handle -> Process Handle) -> IO Handle -> Process Handle
forall a b. (a -> b) -> a -> b
$ String -> IOMode -> IO Handle
openFile String
path IOMode
AppendMode
  IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
  (String -> Process ())
-> Process ()
-> LogLevel
-> (String -> Process String)
-> Process ProcessId
systemLog (IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (String -> IO ()) -> String -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> String -> IO ()
hPutStrLn Handle
h) (IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> IO ()
hClose Handle
h)) LogLevel
lvl String -> Process String
fmt

-- | Start a /system logger/ process as a management agent.
--
systemLog :: (String -> Process ()) -- ^ This expression does the actual logging
          -> (Process ())  -- ^ An expression used to clean up any residual state
          -> LogLevel      -- ^ The initial 'LogLevel' to use
          -> LogFormat     -- ^ An expression used to format logging messages/text
          -> Process ProcessId
systemLog :: (String -> Process ())
-> Process ()
-> LogLevel
-> (String -> Process String)
-> Process ProcessId
systemLog String -> Process ()
o Process ()
c LogLevel
l String -> Process String
f = LogState -> Process ProcessId
go (LogState -> Process ProcessId) -> LogState -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ (String -> Process ())
-> Process ()
-> LogLevel
-> (String -> Process String)
-> [Message -> Process (Maybe String)]
-> LogState
LogState String -> Process ()
o Process ()
c LogLevel
l String -> Process String
f [Message -> Process (Maybe String)]
defaultFormatters
  where
    go :: LogState -> Process ProcessId
    go :: LogState -> Process ProcessId
go LogState
st =
      MxAgentId
-> LogState
-> [MxSink LogState]
-> MxAgent LogState ()
-> Process ProcessId
forall s.
MxAgentId -> s -> [MxSink s] -> MxAgent s () -> Process ProcessId
mxAgentWithFinalize MxAgentId
mxLogId LogState
st [
            -- these are the messages we're /really/ interested in
            ((LogMessage -> MxAgent LogState MxAction) -> MxSink LogState
forall s m. Serializable m => (m -> MxAgent s MxAction) -> MxSink s
mxSink ((LogMessage -> MxAgent LogState MxAction) -> MxSink LogState)
-> (LogMessage -> MxAgent LogState MxAction) -> MxSink LogState
forall a b. (a -> b) -> a -> b
$ \(LogMessage
m :: LogMessage) ->
                case LogMessage
m of
                  (LogMessage String
msg LogLevel
lvl) ->
                    MxAgent LogState LogState
forall s. MxAgent s s
mxGetLocal MxAgent LogState LogState
-> (LogState -> MxAgent LogState ()) -> MxAgent LogState ()
forall a b.
MxAgent LogState a
-> (a -> MxAgent LogState b) -> MxAgent LogState b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LogLevel -> String -> LogState -> MxAgent LogState ()
forall {s}. LogLevel -> String -> LogState -> MxAgent s ()
outputMin LogLevel
lvl String
msg MxAgent LogState ()
-> MxAgent LogState MxAction -> MxAgent LogState MxAction
forall a b.
MxAgent LogState a -> MxAgent LogState b -> MxAgent LogState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MxAgent LogState MxAction
forall s. MxAgent s MxAction
mxReceive
                  (LogData Message
dat LogLevel
lvl) -> Message -> LogLevel -> MxAgent LogState MxAction
handleRawMsg Message
dat LogLevel
lvl)

            -- complex messages rely on properly registered formatters
          , ((MxEvent -> MxAgent LogState MxAction) -> MxSink LogState
forall s m. Serializable m => (m -> MxAgent s MxAction) -> MxSink s
mxSink ((MxEvent -> MxAgent LogState MxAction) -> MxSink LogState)
-> (MxEvent -> MxAgent LogState MxAction) -> MxSink LogState
forall a b. (a -> b) -> a -> b
$ \(MxEvent
ev :: MxEvent) ->
                case MxEvent
ev of
                  (MxUser Message
msg) -> Message -> LogLevel -> MxAgent LogState MxAction
handleRawMsg Message
msg LogLevel
Debug
                  -- we treat trace/log events like regular log events at
                  -- a Debug level (only)
                  (MxLog  String
str) -> MxAgent LogState LogState
forall s. MxAgent s s
mxGetLocal MxAgent LogState LogState
-> (LogState -> MxAgent LogState ()) -> MxAgent LogState ()
forall a b.
MxAgent LogState a
-> (a -> MxAgent LogState b) -> MxAgent LogState b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LogLevel -> String -> LogState -> MxAgent LogState ()
forall {s}. LogLevel -> String -> LogState -> MxAgent s ()
outputMin LogLevel
Debug String
str MxAgent LogState ()
-> MxAgent LogState MxAction -> MxAgent LogState MxAction
forall a b.
MxAgent LogState a -> MxAgent LogState b -> MxAgent LogState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MxAgent LogState MxAction
forall s. MxAgent s MxAction
mxReceive
                  MxEvent
_            -> MxEvent -> MxAgent LogState ()
handleEvent MxEvent
ev MxAgent LogState ()
-> MxAgent LogState MxAction -> MxAgent LogState MxAction
forall a b.
MxAgent LogState a -> MxAgent LogState b -> MxAgent LogState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MxAgent LogState MxAction
forall s. MxAgent s MxAction
mxReceive)

            -- command message handling
          , ((SetLevel -> MxAgent LogState MxAction) -> MxSink LogState
forall s m. Serializable m => (m -> MxAgent s MxAction) -> MxSink s
mxSink ((SetLevel -> MxAgent LogState MxAction) -> MxSink LogState)
-> (SetLevel -> MxAgent LogState MxAction) -> MxSink LogState
forall a b. (a -> b) -> a -> b
$ \(SetLevel LogLevel
lvl) ->
                MxAgent LogState LogState
forall s. MxAgent s s
mxGetLocal MxAgent LogState LogState
-> (LogState -> MxAgent LogState MxAction)
-> MxAgent LogState MxAction
forall a b.
MxAgent LogState a
-> (a -> MxAgent LogState b) -> MxAgent LogState b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \LogState
st' -> LogState -> MxAgent LogState ()
forall s. s -> MxAgent s ()
mxSetLocal LogState
st' { level = lvl } MxAgent LogState ()
-> MxAgent LogState MxAction -> MxAgent LogState MxAction
forall a b.
MxAgent LogState a -> MxAgent LogState b -> MxAgent LogState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MxAgent LogState MxAction
forall s. MxAgent s MxAction
mxReceive)
          , ((AddFormatter -> MxAgent LogState MxAction) -> MxSink LogState
forall s m. Serializable m => (m -> MxAgent s MxAction) -> MxSink s
mxSink ((AddFormatter -> MxAgent LogState MxAction) -> MxSink LogState)
-> (AddFormatter -> MxAgent LogState MxAction) -> MxSink LogState
forall a b. (a -> b) -> a -> b
$ \(AddFormatter Closure (Message -> Process (Maybe String))
f') -> do
                Maybe (Message -> Process (Maybe String))
fmt <- Process (Maybe (Message -> Process (Maybe String)))
-> MxAgent LogState (Maybe (Message -> Process (Maybe String)))
forall a s. Process a -> MxAgent s a
liftMX (Process (Maybe (Message -> Process (Maybe String)))
 -> MxAgent LogState (Maybe (Message -> Process (Maybe String))))
-> Process (Maybe (Message -> Process (Maybe String)))
-> MxAgent LogState (Maybe (Message -> Process (Maybe String)))
forall a b. (a -> b) -> a -> b
$ Process (Maybe (Message -> Process (Maybe String)))
-> (SomeException
    -> Process (Maybe (Message -> Process (Maybe String))))
-> Process (Maybe (Message -> Process (Maybe String)))
forall e a.
(HasCallStack, Exception e) =>
Process a -> (e -> Process a) -> Process a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch (Closure (Message -> Process (Maybe String))
-> Process (Message -> Process (Maybe String))
forall a. Typeable a => Closure a -> Process a
unClosure Closure (Message -> Process (Maybe String))
f' Process (Message -> Process (Maybe String))
-> ((Message -> Process (Maybe String))
    -> Process (Maybe (Message -> Process (Maybe String))))
-> Process (Maybe (Message -> Process (Maybe String)))
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Message -> Process (Maybe String))
-> Process (Maybe (Message -> Process (Maybe String)))
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Message -> Process (Maybe String))
 -> Process (Maybe (Message -> Process (Maybe String))))
-> ((Message -> Process (Maybe String))
    -> Maybe (Message -> Process (Maybe String)))
-> (Message -> Process (Maybe String))
-> Process (Maybe (Message -> Process (Maybe String)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Message -> Process (Maybe String))
-> Maybe (Message -> Process (Maybe String))
forall a. a -> Maybe a
Just)
                                      (\(SomeException
_ :: SomeException) -> Maybe (Message -> Process (Maybe String))
-> Process (Maybe (Message -> Process (Maybe String)))
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Message -> Process (Maybe String))
forall a. Maybe a
Nothing)
                case Maybe (Message -> Process (Maybe String))
fmt of
                  Maybe (Message -> Process (Maybe String))
Nothing -> MxAgent LogState MxAction
forall s. MxAgent s MxAction
mxReady
                  Just Message -> Process (Maybe String)
mf -> do
                    (LogState -> LogState) -> MxAgent LogState ()
forall s. (s -> s) -> MxAgent s ()
mxUpdateLocal (\LogState
s -> LogState
s { formatters = mf:formatters s })
                    MxAgent LogState MxAction
forall s. MxAgent s MxAction
mxReceive)
        ] MxAgent LogState ()
runCleanup

    runCleanup :: MxAgent LogState ()
runCleanup = Process () -> MxAgent LogState ()
forall a s. Process a -> MxAgent s a
liftMX (Process () -> MxAgent LogState ())
-> (LogState -> Process ()) -> LogState -> MxAgent LogState ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogState -> Process ()
cleanup (LogState -> MxAgent LogState ())
-> MxAgent LogState LogState -> MxAgent LogState ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MxAgent LogState LogState
forall s. MxAgent s s
mxGetLocal

    handleRawMsg :: Message -> LogLevel -> MxAgent LogState MxAction
handleRawMsg Message
dat' LogLevel
lvl' = do
      LogState
st <- MxAgent LogState LogState
forall s. MxAgent s s
mxGetLocal
      Maybe String
msg <- Message -> LogState -> MxAgent LogState (Maybe String)
forall {s}. Message -> LogState -> MxAgent s (Maybe String)
formatMsg Message
dat' LogState
st
      case Maybe String
msg of
        Just String
str -> LogLevel -> String -> LogState -> MxAgent LogState ()
forall {s}. LogLevel -> String -> LogState -> MxAgent s ()
outputMin LogLevel
lvl' String
str LogState
st MxAgent LogState ()
-> MxAgent LogState MxAction -> MxAgent LogState MxAction
forall a b.
MxAgent LogState a -> MxAgent LogState b -> MxAgent LogState b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MxAgent LogState MxAction
forall s. MxAgent s MxAction
mxReceive
        Maybe String
Nothing  -> MxAgent LogState MxAction
forall s. MxAgent s MxAction
mxReceive  -- we cannot format a Message, so we ignore it

    handleEvent :: MxEvent -> MxAgent LogState ()
handleEvent (MxConnected    ConnectionId
_ EndPointAddress
ep) =
          MxAgent LogState LogState
forall s. MxAgent s s
mxGetLocal MxAgent LogState LogState
-> (LogState -> MxAgent LogState ()) -> MxAgent LogState ()
forall a b.
MxAgent LogState a
-> (a -> MxAgent LogState b) -> MxAgent LogState b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LogLevel -> String -> LogState -> MxAgent LogState ()
forall {s}. LogLevel -> String -> LogState -> MxAgent s ()
outputMin LogLevel
Notice
                                   (String
"Endpoint: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ EndPointAddress -> String
forall a. Show a => a -> String
show EndPointAddress
ep String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" Disconnected")
    handleEvent (MxDisconnected ConnectionId
_ EndPointAddress
ep) =
          MxAgent LogState LogState
forall s. MxAgent s s
mxGetLocal MxAgent LogState LogState
-> (LogState -> MxAgent LogState ()) -> MxAgent LogState ()
forall a b.
MxAgent LogState a
-> (a -> MxAgent LogState b) -> MxAgent LogState b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LogLevel -> String -> LogState -> MxAgent LogState ()
forall {s}. LogLevel -> String -> LogState -> MxAgent s ()
outputMin LogLevel
Notice
                                   (String
"Endpoint " String -> ShowS
forall a. [a] -> [a] -> [a]
++ EndPointAddress -> String
forall a. Show a => a -> String
show EndPointAddress
ep String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" Connected")
    handleEvent MxEvent
_                     = () -> MxAgent LogState ()
forall a. a -> MxAgent LogState a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    formatMsg :: Message -> LogState -> MxAgent s (Maybe String)
formatMsg Message
m LogState{[Message -> Process (Maybe String)]
Process ()
LogLevel
String -> Process String
String -> Process ()
output :: LogState -> String -> Process ()
cleanup :: LogState -> Process ()
level :: LogState -> LogLevel
format :: LogState -> String -> Process String
formatters :: LogState -> [Message -> Process (Maybe String)]
output :: String -> Process ()
cleanup :: Process ()
level :: LogLevel
format :: String -> Process String
formatters :: [Message -> Process (Maybe String)]
..} = let fms :: [Message -> Process (Maybe String)]
fms = [Message -> Process (Maybe String)]
formatters in Message
-> [Message -> Process (Maybe String)] -> MxAgent s (Maybe String)
forall {t} {a} {s}.
t -> [t -> Process (Maybe a)] -> MxAgent s (Maybe a)
formatMsg' Message
m [Message -> Process (Maybe String)]
fms

    formatMsg' :: t -> [t -> Process (Maybe a)] -> MxAgent s (Maybe a)
formatMsg' t
_ []     = Maybe a -> MxAgent s (Maybe a)
forall a. a -> MxAgent s a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    formatMsg' t
m (t -> Process (Maybe a)
f':[t -> Process (Maybe a)]
fs) = do
      Maybe a
res <- Process (Maybe a) -> MxAgent s (Maybe a)
forall a s. Process a -> MxAgent s a
liftMX (Process (Maybe a) -> MxAgent s (Maybe a))
-> Process (Maybe a) -> MxAgent s (Maybe a)
forall a b. (a -> b) -> a -> b
$ t -> Process (Maybe a)
f' t
m
      case Maybe a
res of
        ok :: Maybe a
ok@(Just a
_) -> Maybe a -> MxAgent s (Maybe a)
forall a. a -> MxAgent s a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
ok
        Maybe a
Nothing     -> t -> [t -> Process (Maybe a)] -> MxAgent s (Maybe a)
formatMsg' t
m [t -> Process (Maybe a)]
fs

    outputMin :: LogLevel -> String -> LogState -> MxAgent s ()
outputMin LogLevel
minLvl String
msgData LogState{[Message -> Process (Maybe String)]
Process ()
LogLevel
String -> Process String
String -> Process ()
output :: LogState -> String -> Process ()
cleanup :: LogState -> Process ()
level :: LogState -> LogLevel
format :: LogState -> String -> Process String
formatters :: LogState -> [Message -> Process (Maybe String)]
output :: String -> Process ()
cleanup :: Process ()
level :: LogLevel
format :: String -> Process String
formatters :: [Message -> Process (Maybe String)]
..} =
      case LogLevel
minLvl LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
level of
        Bool
True  -> Process () -> MxAgent s ()
forall a s. Process a -> MxAgent s a
liftMX (String -> Process String
format String
msgData Process String -> (String -> Process ()) -> Process ()
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Process ()
output)
        Bool
False -> () -> MxAgent s ()
forall a. a -> MxAgent s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    defaultFormatters :: [Message -> Process (Maybe String)]
defaultFormatters = [Message -> Process (Maybe String)
basicDataFormat]

basicDataFormat :: Message -> Process (Maybe String)
basicDataFormat :: Message -> Process (Maybe String)
basicDataFormat = Message -> Process (Maybe String)
forall (m :: * -> *) a.
(Monad m, Serializable a) =>
Message -> m (Maybe a)
unwrapMessage