{-# LANGUAGE RecordWildCards #-}
-- | This module implements the logging thread. This thread can
-- optionally write logged messages to an output file. When the thread
-- is created, it is initially not writing to any output file and
-- must be told to do so by issuing a LogCommand using the LogManager
-- interface.
--
-- The logging thread has an internal bounded log message buffer. Logged
-- messages always get written to the buffer (potentially evicting old
-- messages to maintain the size bound). If the thread is also writing
-- to a file, such messages also get written to the file. When the
-- thread begins logging to a file, the entire buffer is written to the
-- file so that a historical snapshot of log activity can be saved in
-- cases where logging is turned on at runtime only once a problematic
-- behavior is observed.
module Matterhorn.State.Setup.Threads.Logging
  ( newLogManager
  , shutdownLogManager
  )
where

import           Prelude ()
import           Matterhorn.Prelude

import           Brick.BChan ( BChan )
import           Control.Concurrent.Async ( Async, async, wait )
import qualified Control.Concurrent.STM as STM
import           Control.Exception ( SomeException, try )
import           Control.Monad.State.Strict
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import           Data.Time ( getCurrentTime )
import           System.IO ( Handle, IOMode(AppendMode), hPutStr, hPutStrLn
                           , hFlush, openFile, hClose )

import           Matterhorn.Types


-- | Used to remember the last logging output point for various log output targets.
newtype LogMemory = LogMemory { LogMemory -> [(FilePath, LogMessage)]
logMem :: [(FilePath, LogMessage)] }

blankLogMemory :: LogMemory
blankLogMemory :: LogMemory
blankLogMemory = [(FilePath, LogMessage)] -> LogMemory
LogMemory []

-- | Adds or updates the last log message output to this destination.
-- This is used for the case when logging is re-enabled to that
-- destination to avoid repeating logging output.
--
-- The number of log memories is limited by forgetting the oldest ones
-- if over a threshold.  This handles a pathological case where the
-- user has redirected output to a very large number of logfiles.
-- This is very unlikely to happen (a script or bad paste buffer
-- maybe?) but this provides defensive behavior to prevent
-- uncontrolled memory consumption in this case.  The limit here is
-- arbitrary, but it should suffice and once it's reached the
-- degradation case is simply the potential for duplicated messages
-- when returning to logfiles that haven't been recently logged to.
rememberOutputPoint :: FilePath -> LogMessage -> LogMemory -> LogMemory
rememberOutputPoint :: FilePath -> LogMessage -> LogMemory -> LogMemory
rememberOutputPoint FilePath
logPath LogMessage
logMsg LogMemory
oldLogMem =
  [(FilePath, LogMessage)] -> LogMemory
LogMemory ([(FilePath, LogMessage)] -> LogMemory)
-> [(FilePath, LogMessage)] -> LogMemory
forall a b. (a -> b) -> a -> b
$
  Int -> [(FilePath, LogMessage)] -> [(FilePath, LogMessage)]
forall a. Int -> [a] -> [a]
take Int
50 ([(FilePath, LogMessage)] -> [(FilePath, LogMessage)])
-> [(FilePath, LogMessage)] -> [(FilePath, LogMessage)]
forall a b. (a -> b) -> a -> b
$ -- upper limit on number of logpath+message memories retained
  (FilePath
logPath, LogMessage
logMsg) (FilePath, LogMessage)
-> [(FilePath, LogMessage)] -> [(FilePath, LogMessage)]
forall a. a -> [a] -> [a]
: ((FilePath, LogMessage) -> Bool)
-> [(FilePath, LogMessage)] -> [(FilePath, LogMessage)]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
(/=) FilePath
logPath (FilePath -> Bool)
-> ((FilePath, LogMessage) -> FilePath)
-> (FilePath, LogMessage)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, LogMessage) -> FilePath
forall a b. (a, b) -> a
fst) (LogMemory -> [(FilePath, LogMessage)]
logMem LogMemory
oldLogMem)

-- | Returns the last LogMessage logged to the specified output log
-- file path if it was previously logged to.
memoryOfOutputPath :: FilePath -> LogMemory -> Maybe LogMessage
memoryOfOutputPath :: FilePath -> LogMemory -> Maybe LogMessage
memoryOfOutputPath FilePath
p = FilePath -> [(FilePath, LogMessage)] -> Maybe LogMessage
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
p ([(FilePath, LogMessage)] -> Maybe LogMessage)
-> (LogMemory -> [(FilePath, LogMessage)])
-> LogMemory
-> Maybe LogMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogMemory -> [(FilePath, LogMessage)]
logMem

-- | The state of the logging thread.
data LogThreadState =
    LogThreadState { LogThreadState -> Maybe (FilePath, Handle)
logThreadDestination :: Maybe (FilePath, Handle)
                   -- ^ The logging thread's active logging destination.
                   -- Nothing means log messages are not being written
                   -- anywhere except the internal buffer.
                   , LogThreadState -> BChan MHEvent
logThreadEventChan :: BChan MHEvent
                   -- ^ The application event channel that we'll use to
                   -- notify of logging events.
                   , LogThreadState -> TChan LogCommand
logThreadCommandChan :: STM.TChan LogCommand
                   -- ^ The channel on which the logging thread will
                   -- wait for logging commands.
                   , LogThreadState -> Seq LogMessage
logThreadMessageBuffer :: Seq.Seq LogMessage
                   -- ^ The internal bounded log message buffer.
                   , LogThreadState -> Int
logThreadMaxBufferSize :: Int
                   -- ^ The size bound of the logThreadMessageBuffer.
                   , LogThreadState -> LogMemory
logPreviousStopPoint :: LogMemory
                   -- ^ Previous logging stop points to avoid
                   -- duplication if logging is re-enabled to the same
                   -- output
                   }

-- | Create a new log manager and start a logging thread for it.
newLogManager :: BChan MHEvent -> Int -> IO LogManager
newLogManager :: BChan MHEvent -> Int -> IO LogManager
newLogManager BChan MHEvent
eventChan Int
maxBufferSize = do
    TChan LogCommand
chan <- IO (TChan LogCommand)
forall a. IO (TChan a)
STM.newTChanIO
    Async ()
self <- BChan MHEvent -> TChan LogCommand -> Int -> IO (Async ())
startLoggingThread BChan MHEvent
eventChan TChan LogCommand
chan Int
maxBufferSize
    let mgr :: LogManager
mgr = LogManager :: TChan LogCommand -> Async () -> LogManager
LogManager { logManagerCommandChannel :: TChan LogCommand
logManagerCommandChannel = TChan LogCommand
chan
                         , logManagerHandle :: Async ()
logManagerHandle = Async ()
self
                         }
    LogManager -> IO LogManager
forall (m :: * -> *) a. Monad m => a -> m a
return LogManager
mgr

-- | Shuts down the log manager and blocks until shutdown is complete.
shutdownLogManager :: LogManager -> IO ()
shutdownLogManager :: LogManager -> IO ()
shutdownLogManager LogManager
mgr = do
    STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan LogCommand -> LogCommand -> STM ()
forall a. TChan a -> a -> STM ()
STM.writeTChan (LogManager -> TChan LogCommand
logManagerCommandChannel LogManager
mgr) LogCommand
ShutdownLogging
    Async () -> IO ()
forall a. Async a -> IO a
wait (Async () -> IO ()) -> Async () -> IO ()
forall a b. (a -> b) -> a -> b
$ LogManager -> Async ()
logManagerHandle LogManager
mgr

-- | The logging thread.
startLoggingThread :: BChan MHEvent -> STM.TChan LogCommand -> Int -> IO (Async ())
startLoggingThread :: BChan MHEvent -> TChan LogCommand -> Int -> IO (Async ())
startLoggingThread BChan MHEvent
eventChan TChan LogCommand
logChan Int
maxBufferSize = do
    let initialState :: LogThreadState
initialState = LogThreadState :: Maybe (FilePath, Handle)
-> BChan MHEvent
-> TChan LogCommand
-> Seq LogMessage
-> Int
-> LogMemory
-> LogThreadState
LogThreadState { logThreadDestination :: Maybe (FilePath, Handle)
logThreadDestination = Maybe (FilePath, Handle)
forall a. Maybe a
Nothing
                                      , logThreadEventChan :: BChan MHEvent
logThreadEventChan = BChan MHEvent
eventChan
                                      , logThreadCommandChan :: TChan LogCommand
logThreadCommandChan = TChan LogCommand
logChan
                                      , logThreadMessageBuffer :: Seq LogMessage
logThreadMessageBuffer = Seq LogMessage
forall a. Monoid a => a
mempty
                                      , logThreadMaxBufferSize :: Int
logThreadMaxBufferSize = Int
maxBufferSize
                                      , logPreviousStopPoint :: LogMemory
logPreviousStopPoint = LogMemory
blankLogMemory
                                      }
    IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO ((), LogThreadState) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ((), LogThreadState) -> IO ())
-> IO ((), LogThreadState) -> IO ()
forall a b. (a -> b) -> a -> b
$ StateT LogThreadState IO ()
-> LogThreadState -> IO ((), LogThreadState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT LogThreadState IO ()
logThreadBody LogThreadState
initialState

logThreadBody :: StateT LogThreadState IO ()
logThreadBody :: StateT LogThreadState IO ()
logThreadBody = do
    LogCommand
cmd <- StateT LogThreadState IO LogCommand
nextLogCommand
    Bool
continue <- LogCommand -> StateT LogThreadState IO Bool
handleLogCommand LogCommand
cmd
    Bool -> StateT LogThreadState IO () -> StateT LogThreadState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
continue StateT LogThreadState IO ()
logThreadBody

-- | Get the next pending log thread command.
nextLogCommand :: StateT LogThreadState IO LogCommand
nextLogCommand :: StateT LogThreadState IO LogCommand
nextLogCommand = do
    TChan LogCommand
chan <- (LogThreadState -> TChan LogCommand)
-> StateT LogThreadState IO (TChan LogCommand)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LogThreadState -> TChan LogCommand
logThreadCommandChan
    IO LogCommand -> StateT LogThreadState IO LogCommand
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LogCommand -> StateT LogThreadState IO LogCommand)
-> IO LogCommand -> StateT LogThreadState IO LogCommand
forall a b. (a -> b) -> a -> b
$ STM LogCommand -> IO LogCommand
forall a. STM a -> IO a
STM.atomically (STM LogCommand -> IO LogCommand)
-> STM LogCommand -> IO LogCommand
forall a b. (a -> b) -> a -> b
$ TChan LogCommand -> STM LogCommand
forall a. TChan a -> STM a
STM.readTChan TChan LogCommand
chan

putMarkerMessage :: String -> Handle -> IO ()
putMarkerMessage :: FilePath -> Handle -> IO ()
putMarkerMessage FilePath
msg Handle
h = do
    UTCTime
now <- IO UTCTime
getCurrentTime
    Handle -> FilePath -> IO ()
hPutStrLn Handle
h (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"[" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> UTCTime -> FilePath
forall a. Show a => a -> FilePath
show UTCTime
now FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"] " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
msg

-- | Emit a log stop marker to the file.
putLogEndMarker :: Handle -> IO ()
putLogEndMarker :: Handle -> IO ()
putLogEndMarker = FilePath -> Handle -> IO ()
putMarkerMessage FilePath
"<<< Logging end >>>"

-- | Emit a log start marker to the file.
putLogStartMarker :: Handle -> IO ()
putLogStartMarker :: Handle -> IO ()
putLogStartMarker = FilePath -> Handle -> IO ()
putMarkerMessage FilePath
"<<< Logging start >>>"

-- | Emit a log stop marker to the file and close it, then notify the
-- application that we have stopped logging.
finishLog :: BChan MHEvent -> FilePath -> Handle -> StateT LogThreadState IO ()
finishLog :: BChan MHEvent -> FilePath -> Handle -> StateT LogThreadState IO ()
finishLog BChan MHEvent
eventChan FilePath
oldPath Handle
oldHandle = do
    IO () -> StateT LogThreadState IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT LogThreadState IO ())
-> IO () -> StateT LogThreadState IO ()
forall a b. (a -> b) -> a -> b
$ do
        Handle -> IO ()
putLogEndMarker Handle
oldHandle
        Handle -> IO ()
hClose Handle
oldHandle
        BChan MHEvent -> MHEvent -> IO ()
forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan (MHEvent -> IO ()) -> MHEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ InternalEvent -> MHEvent
IEvent (InternalEvent -> MHEvent) -> InternalEvent -> MHEvent
forall a b. (a -> b) -> a -> b
$ FilePath -> InternalEvent
LoggingStopped FilePath
oldPath
    (LogThreadState -> LogThreadState) -> StateT LogThreadState IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LogThreadState -> LogThreadState) -> StateT LogThreadState IO ())
-> (LogThreadState -> LogThreadState)
-> StateT LogThreadState IO ()
forall a b. (a -> b) -> a -> b
$ \LogThreadState
s ->
      let buf :: Seq LogMessage
buf = LogThreadState -> Seq LogMessage
logThreadMessageBuffer LogThreadState
s
          lastLm :: LogMessage
lastLm = Seq LogMessage -> Int -> LogMessage
forall a. Seq a -> Int -> a
Seq.index Seq LogMessage
buf (Seq LogMessage -> Int
forall a. Seq a -> Int
Seq.length Seq LogMessage
buf Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) -- n.b. putLogEndMarker ensures buf not empty
          stops :: LogMemory
stops = FilePath -> LogMessage -> LogMemory -> LogMemory
rememberOutputPoint FilePath
oldPath LogMessage
lastLm (LogMemory -> LogMemory) -> LogMemory -> LogMemory
forall a b. (a -> b) -> a -> b
$ LogThreadState -> LogMemory
logPreviousStopPoint LogThreadState
s
      in LogThreadState
s { logThreadDestination :: Maybe (FilePath, Handle)
logThreadDestination = Maybe (FilePath, Handle)
forall a. Maybe a
Nothing
           , logPreviousStopPoint :: LogMemory
logPreviousStopPoint = LogMemory
stops
           }

stopLogOutput :: StateT LogThreadState IO ()
stopLogOutput :: StateT LogThreadState IO ()
stopLogOutput = do
    Maybe (FilePath, Handle)
oldDest <- (LogThreadState -> Maybe (FilePath, Handle))
-> StateT LogThreadState IO (Maybe (FilePath, Handle))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LogThreadState -> Maybe (FilePath, Handle)
logThreadDestination
    case Maybe (FilePath, Handle)
oldDest of
        Maybe (FilePath, Handle)
Nothing -> () -> StateT LogThreadState IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just (FilePath
oldPath, Handle
oldHandle) -> do
            BChan MHEvent
eventChan <- (LogThreadState -> BChan MHEvent)
-> StateT LogThreadState IO (BChan MHEvent)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LogThreadState -> BChan MHEvent
logThreadEventChan
            BChan MHEvent -> FilePath -> Handle -> StateT LogThreadState IO ()
finishLog BChan MHEvent
eventChan FilePath
oldPath Handle
oldHandle

-- | Handle a single logging command.
handleLogCommand :: LogCommand -> StateT LogThreadState IO Bool
handleLogCommand :: LogCommand -> StateT LogThreadState IO Bool
handleLogCommand (LogSnapshot FilePath
path) = do
    -- LogSnapshot: write the current log message buffer to the
    -- specified path. Ignore the request if it is for the path that we
    -- are already logging to.
    BChan MHEvent
eventChan <- (LogThreadState -> BChan MHEvent)
-> StateT LogThreadState IO (BChan MHEvent)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LogThreadState -> BChan MHEvent
logThreadEventChan
    Maybe (FilePath, Handle)
dest <- (LogThreadState -> Maybe (FilePath, Handle))
-> StateT LogThreadState IO (Maybe (FilePath, Handle))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LogThreadState -> Maybe (FilePath, Handle)
logThreadDestination

    let shouldWrite :: Bool
shouldWrite = case Maybe (FilePath, Handle)
dest of
          Maybe (FilePath, Handle)
Nothing -> Bool
True
          Just (FilePath
curPath, Handle
_) -> FilePath
curPath FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
path

    Bool -> StateT LogThreadState IO () -> StateT LogThreadState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldWrite (StateT LogThreadState IO () -> StateT LogThreadState IO ())
-> StateT LogThreadState IO () -> StateT LogThreadState IO ()
forall a b. (a -> b) -> a -> b
$ do
        Either SomeException Handle
result <- IO (Either SomeException Handle)
-> StateT LogThreadState IO (Either SomeException Handle)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException Handle)
 -> StateT LogThreadState IO (Either SomeException Handle))
-> IO (Either SomeException Handle)
-> StateT LogThreadState IO (Either SomeException Handle)
forall a b. (a -> b) -> a -> b
$ IO Handle -> IO (Either SomeException Handle)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO Handle -> IO (Either SomeException Handle))
-> IO Handle -> IO (Either SomeException Handle)
forall a b. (a -> b) -> a -> b
$ FilePath -> IOMode -> IO Handle
openFile FilePath
path IOMode
AppendMode
        case Either SomeException Handle
result of
            Left (SomeException
e::SomeException) -> do
                IO () -> StateT LogThreadState IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT LogThreadState IO ())
-> IO () -> StateT LogThreadState IO ()
forall a b. (a -> b) -> a -> b
$ BChan MHEvent -> MHEvent -> IO ()
forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan (MHEvent -> IO ()) -> MHEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ InternalEvent -> MHEvent
IEvent (InternalEvent -> MHEvent) -> InternalEvent -> MHEvent
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> InternalEvent
LogSnapshotFailed FilePath
path (SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e)
            Right Handle
handle -> do
                FilePath -> Handle -> StateT LogThreadState IO ()
flushLogMessageBuffer FilePath
path Handle
handle
                IO () -> StateT LogThreadState IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT LogThreadState IO ())
-> IO () -> StateT LogThreadState IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
handle
                IO () -> StateT LogThreadState IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT LogThreadState IO ())
-> IO () -> StateT LogThreadState IO ()
forall a b. (a -> b) -> a -> b
$ BChan MHEvent -> MHEvent -> IO ()
forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan (MHEvent -> IO ()) -> MHEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ InternalEvent -> MHEvent
IEvent (InternalEvent -> MHEvent) -> InternalEvent -> MHEvent
forall a b. (a -> b) -> a -> b
$ FilePath -> InternalEvent
LogSnapshotSucceeded FilePath
path

    Bool -> StateT LogThreadState IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
handleLogCommand LogCommand
GetLogDestination = do
    -- GetLogDestination: the application asked us to provide the
    -- current log destination.
    Maybe (FilePath, Handle)
dest <- (LogThreadState -> Maybe (FilePath, Handle))
-> StateT LogThreadState IO (Maybe (FilePath, Handle))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LogThreadState -> Maybe (FilePath, Handle)
logThreadDestination
    BChan MHEvent
eventChan <- (LogThreadState -> BChan MHEvent)
-> StateT LogThreadState IO (BChan MHEvent)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LogThreadState -> BChan MHEvent
logThreadEventChan
    IO () -> StateT LogThreadState IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT LogThreadState IO ())
-> IO () -> StateT LogThreadState IO ()
forall a b. (a -> b) -> a -> b
$ BChan MHEvent -> MHEvent -> IO ()
forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan (MHEvent -> IO ()) -> MHEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ InternalEvent -> MHEvent
IEvent (InternalEvent -> MHEvent) -> InternalEvent -> MHEvent
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> InternalEvent
LogDestination (Maybe FilePath -> InternalEvent)
-> Maybe FilePath -> InternalEvent
forall a b. (a -> b) -> a -> b
$ (FilePath, Handle) -> FilePath
forall a b. (a, b) -> a
fst ((FilePath, Handle) -> FilePath)
-> Maybe (FilePath, Handle) -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (FilePath, Handle)
dest
    Bool -> StateT LogThreadState IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
handleLogCommand LogCommand
ShutdownLogging = do
    -- ShutdownLogging: if we were logging to a file, close it. Then
    -- unlock the shutdown lock.
    StateT LogThreadState IO ()
stopLogOutput
    Bool -> StateT LogThreadState IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
handleLogCommand LogCommand
StopLogging = do
    -- StopLogging: if we were logging to a file, close it and notify
    -- the application. Otherwise do nothing.
    StateT LogThreadState IO ()
stopLogOutput
    Bool -> StateT LogThreadState IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
handleLogCommand (LogToFile FilePath
newPath) = do
    -- LogToFile: if we were logging to a file, close that file, notify
    -- the application, then attempt to open the new file. If that
    -- failed, notify the application of the error. If it succeeded,
    -- start logging and notify the application.
    BChan MHEvent
eventChan <- (LogThreadState -> BChan MHEvent)
-> StateT LogThreadState IO (BChan MHEvent)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LogThreadState -> BChan MHEvent
logThreadEventChan
    Maybe (FilePath, Handle)
oldDest <- (LogThreadState -> Maybe (FilePath, Handle))
-> StateT LogThreadState IO (Maybe (FilePath, Handle))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LogThreadState -> Maybe (FilePath, Handle)
logThreadDestination

    Bool
shouldChange <- case Maybe (FilePath, Handle)
oldDest of
        Maybe (FilePath, Handle)
Nothing ->
            Bool -> StateT LogThreadState IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Just (FilePath
oldPath, Handle
_) ->
            Bool -> StateT LogThreadState IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
oldPath FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
newPath)

    Bool -> StateT LogThreadState IO () -> StateT LogThreadState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldChange (StateT LogThreadState IO () -> StateT LogThreadState IO ())
-> StateT LogThreadState IO () -> StateT LogThreadState IO ()
forall a b. (a -> b) -> a -> b
$ do
        Either SomeException Handle
result <- IO (Either SomeException Handle)
-> StateT LogThreadState IO (Either SomeException Handle)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException Handle)
 -> StateT LogThreadState IO (Either SomeException Handle))
-> IO (Either SomeException Handle)
-> StateT LogThreadState IO (Either SomeException Handle)
forall a b. (a -> b) -> a -> b
$ IO Handle -> IO (Either SomeException Handle)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO Handle -> IO (Either SomeException Handle))
-> IO Handle -> IO (Either SomeException Handle)
forall a b. (a -> b) -> a -> b
$ FilePath -> IOMode -> IO Handle
openFile FilePath
newPath IOMode
AppendMode
        case Either SomeException Handle
result of
            Left (SomeException
e::SomeException) -> IO () -> StateT LogThreadState IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT LogThreadState IO ())
-> IO () -> StateT LogThreadState IO ()
forall a b. (a -> b) -> a -> b
$ do
                let msg :: FilePath
msg = FilePath
"Error in log thread: could not open " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
newPath FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
                          FilePath
": " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e
                BChan MHEvent -> MHEvent -> IO ()
forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan (MHEvent -> IO ()) -> MHEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ InternalEvent -> MHEvent
IEvent (InternalEvent -> MHEvent) -> InternalEvent -> MHEvent
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> InternalEvent
LogStartFailed FilePath
newPath FilePath
msg
            Right Handle
handle -> do
                StateT LogThreadState IO ()
stopLogOutput

                (LogThreadState -> LogThreadState) -> StateT LogThreadState IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LogThreadState -> LogThreadState) -> StateT LogThreadState IO ())
-> (LogThreadState -> LogThreadState)
-> StateT LogThreadState IO ()
forall a b. (a -> b) -> a -> b
$ \LogThreadState
s -> LogThreadState
s { logThreadDestination :: Maybe (FilePath, Handle)
logThreadDestination = (FilePath, Handle) -> Maybe (FilePath, Handle)
forall a. a -> Maybe a
Just (FilePath
newPath, Handle
handle) }
                FilePath -> Handle -> StateT LogThreadState IO ()
flushLogMessageBuffer FilePath
newPath Handle
handle
                IO () -> StateT LogThreadState IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT LogThreadState IO ())
-> IO () -> StateT LogThreadState IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
putLogStartMarker Handle
handle
                IO () -> StateT LogThreadState IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT LogThreadState IO ())
-> IO () -> StateT LogThreadState IO ()
forall a b. (a -> b) -> a -> b
$ BChan MHEvent -> MHEvent -> IO ()
forall (m :: * -> *). MonadIO m => BChan MHEvent -> MHEvent -> m ()
writeBChan BChan MHEvent
eventChan (MHEvent -> IO ()) -> MHEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ InternalEvent -> MHEvent
IEvent (InternalEvent -> MHEvent) -> InternalEvent -> MHEvent
forall a b. (a -> b) -> a -> b
$ FilePath -> InternalEvent
LoggingStarted FilePath
newPath

    Bool -> StateT LogThreadState IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
handleLogCommand (LogAMessage LogMessage
lm) = do
    -- LogAMessage: log a single message. Write the message to the
    -- bounded internal buffer (which may cause an older message to be
    -- evicted). Then, if we are actively logging to a file, write the
    -- message to that file and flush the output stream.
    Int
maxBufSize <- (LogThreadState -> Int) -> StateT LogThreadState IO Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LogThreadState -> Int
logThreadMaxBufferSize

    let addMessageToBuffer :: Seq LogMessage -> Seq LogMessage
addMessageToBuffer Seq LogMessage
s =
            -- Ensure that newSeq is always at most maxBufSize elements
            -- long.
            let newSeq :: Seq LogMessage
newSeq = Seq LogMessage
s Seq LogMessage -> LogMessage -> Seq LogMessage
forall a. Seq a -> a -> Seq a
Seq.|> LogMessage
lm
                toDrop :: Int
toDrop = Seq LogMessage -> Int
forall a. Seq a -> Int
Seq.length Seq LogMessage
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
maxBufSize
            in Int -> Seq LogMessage -> Seq LogMessage
forall a. Int -> Seq a -> Seq a
Seq.drop Int
toDrop Seq LogMessage
newSeq

    -- Append the message to the internal buffer, maintaining the bound
    -- on the internal buffer size.
    (LogThreadState -> LogThreadState) -> StateT LogThreadState IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LogThreadState -> LogThreadState) -> StateT LogThreadState IO ())
-> (LogThreadState -> LogThreadState)
-> StateT LogThreadState IO ()
forall a b. (a -> b) -> a -> b
$ \LogThreadState
s -> LogThreadState
s { logThreadMessageBuffer :: Seq LogMessage
logThreadMessageBuffer = Seq LogMessage -> Seq LogMessage
addMessageToBuffer (LogThreadState -> Seq LogMessage
logThreadMessageBuffer LogThreadState
s) }

    -- If we have an active log destination, write the message to the
    -- output file.
    Maybe (FilePath, Handle)
dest <- (LogThreadState -> Maybe (FilePath, Handle))
-> StateT LogThreadState IO (Maybe (FilePath, Handle))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LogThreadState -> Maybe (FilePath, Handle)
logThreadDestination
    case Maybe (FilePath, Handle)
dest of
        Maybe (FilePath, Handle)
Nothing -> () -> StateT LogThreadState IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just (FilePath
_, Handle
handle) -> IO () -> StateT LogThreadState IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT LogThreadState IO ())
-> IO () -> StateT LogThreadState IO ()
forall a b. (a -> b) -> a -> b
$ do
            Handle -> LogMessage -> IO ()
hPutLogMessage Handle
handle LogMessage
lm
            Handle -> IO ()
hFlush Handle
handle

    Bool -> StateT LogThreadState IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- | Write a single log message to the output handle.
hPutLogMessage :: Handle -> LogMessage -> IO ()
hPutLogMessage :: Handle -> LogMessage -> IO ()
hPutLogMessage Handle
handle (LogMessage {Maybe LogContext
UTCTime
Text
LogCategory
logMessageTimestamp :: LogMessage -> UTCTime
logMessageCategory :: LogMessage -> LogCategory
logMessageContext :: LogMessage -> Maybe LogContext
logMessageText :: LogMessage -> Text
logMessageTimestamp :: UTCTime
logMessageCategory :: LogCategory
logMessageContext :: Maybe LogContext
logMessageText :: Text
..}) = do
    Handle -> FilePath -> IO ()
hPutStr Handle
handle (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"[" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> UTCTime -> FilePath
forall a. Show a => a -> FilePath
show UTCTime
logMessageTimestamp FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"] "
    Handle -> FilePath -> IO ()
hPutStr Handle
handle (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"[" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> LogCategory -> FilePath
forall a. Show a => a -> FilePath
show LogCategory
logMessageCategory FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"] "
    case Maybe LogContext
logMessageContext of
        Maybe LogContext
Nothing -> Handle -> FilePath -> IO ()
hPutStr Handle
handle FilePath
"[*] "
        Just LogContext
c  -> Handle -> FilePath -> IO ()
hPutStr Handle
handle (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"[" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> LogContext -> FilePath
forall a. Show a => a -> FilePath
show LogContext
c FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"] "
    Handle -> FilePath -> IO ()
hPutStrLn Handle
handle (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
logMessageText

-- | Flush the contents of the internal log message buffer.
flushLogMessageBuffer :: FilePath -> Handle -> StateT LogThreadState IO ()
flushLogMessageBuffer :: FilePath -> Handle -> StateT LogThreadState IO ()
flushLogMessageBuffer FilePath
pathOfHandle Handle
handle = do
    Seq LogMessage
buf <- (LogThreadState -> Seq LogMessage)
-> StateT LogThreadState IO (Seq LogMessage)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LogThreadState -> Seq LogMessage
logThreadMessageBuffer
    Bool -> StateT LogThreadState IO () -> StateT LogThreadState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Seq LogMessage -> Bool
forall a. Seq a -> Bool
Seq.null Seq LogMessage
buf) (StateT LogThreadState IO () -> StateT LogThreadState IO ())
-> StateT LogThreadState IO () -> StateT LogThreadState IO ()
forall a b. (a -> b) -> a -> b
$ do
      Maybe LogMessage
lastPoint <- FilePath -> LogMemory -> Maybe LogMessage
memoryOfOutputPath FilePath
pathOfHandle (LogMemory -> Maybe LogMessage)
-> StateT LogThreadState IO LogMemory
-> StateT LogThreadState IO (Maybe LogMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LogThreadState -> LogMemory) -> StateT LogThreadState IO LogMemory
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LogThreadState -> LogMemory
logPreviousStopPoint
      case Maybe LogMessage
lastPoint of
        Maybe LogMessage
Nothing ->
          -- never logged to this output point before, so dump the
          -- current internal buffer of log messages to the beginning of
          -- the output file.
          Seq LogMessage -> StateT LogThreadState IO ()
forall (m :: * -> *). MonadIO m => Seq LogMessage -> m ()
dumpBuf Seq LogMessage
buf
        Just LogMessage
lm ->
          -- There was previous logging to this file.  If the log buffer
          -- contains the entirety of the log messages during the
          -- logging disable, then just dump that portion; otherwise
          -- dump the entire buffer and indicate there may be missing
          -- entries before the buffer.
          let unseen :: Seq LogMessage
unseen = (LogMessage -> Bool) -> Seq LogMessage -> Seq LogMessage
forall a. (a -> Bool) -> Seq a -> Seq a
Seq.takeWhileR (Bool -> Bool
not (Bool -> Bool) -> (LogMessage -> Bool) -> LogMessage -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogMessage -> LogMessage -> Bool
forall a. Eq a => a -> a -> Bool
(==) LogMessage
lm) Seq LogMessage
buf
              firstM :: LogMessage
firstM = Seq LogMessage -> Int -> LogMessage
forall a. Seq a -> Int -> a
Seq.index Seq LogMessage
buf Int
0 -- above ensures that buf is not empty here
          in do Bool -> StateT LogThreadState IO () -> StateT LogThreadState IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Seq LogMessage -> Int
forall a. Seq a -> Int
Seq.length Seq LogMessage
buf Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Seq LogMessage -> Int
forall a. Seq a -> Int
Seq.length Seq LogMessage
unseen) (StateT LogThreadState IO () -> StateT LogThreadState IO ())
-> StateT LogThreadState IO () -> StateT LogThreadState IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> StateT LogThreadState IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT LogThreadState IO ())
-> IO () -> StateT LogThreadState IO ()
forall a b. (a -> b) -> a -> b
$
                  Handle -> FilePath -> IO ()
hPutStrLn Handle
handle (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ UTCTime -> FilePath -> FilePath
forall a. Show a => a -> FilePath -> FilePath
mkMsg (LogMessage -> UTCTime
logMessageTimestamp LogMessage
firstM)
                                     FilePath
"<<< Potentially missing log messages here... >>>"
                Seq LogMessage -> StateT LogThreadState IO ()
forall (m :: * -> *). MonadIO m => Seq LogMessage -> m ()
dumpBuf Seq LogMessage
unseen
      where
        mkMsg :: a -> FilePath -> FilePath
mkMsg a
t FilePath
m = FilePath
"[" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> a -> FilePath
forall a. Show a => a -> FilePath
show a
t FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"] " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
m
        dumpBuf :: Seq LogMessage -> m ()
dumpBuf Seq LogMessage
buf = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          let firstLm :: LogMessage
firstLm = Seq LogMessage -> Int -> LogMessage
forall a. Seq a -> Int -> a
Seq.index Seq LogMessage
buf Int
0
              lastLm :: LogMessage
lastLm = Seq LogMessage -> Int -> LogMessage
forall a. Seq a -> Int -> a
Seq.index Seq LogMessage
buf (Seq LogMessage -> Int
forall a. Seq a -> Int
Seq.length Seq LogMessage
buf Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

          Handle -> FilePath -> IO ()
hPutStrLn Handle
handle (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ UTCTime -> FilePath -> FilePath
forall a. Show a => a -> FilePath -> FilePath
mkMsg (LogMessage -> UTCTime
logMessageTimestamp LogMessage
firstLm)
                             FilePath
"<<< Log message buffer begin >>>"

          Seq LogMessage -> (LogMessage -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Seq LogMessage
buf (Handle -> LogMessage -> IO ()
hPutLogMessage Handle
handle)

          Handle -> FilePath -> IO ()
hPutStrLn Handle
handle (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ UTCTime -> FilePath -> FilePath
forall a. Show a => a -> FilePath -> FilePath
mkMsg (LogMessage -> UTCTime
logMessageTimestamp LogMessage
lastLm)
                                   FilePath
"<<< Log message buffer end >>>"

          Handle -> IO ()
hFlush Handle
handle