{-# LANGUAGE RecordWildCards #-}
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
newtype LogMemory = LogMemory { LogMemory -> [(String, LogMessage)]
logMem :: [(FilePath, LogMessage)] }
blankLogMemory :: LogMemory
blankLogMemory :: LogMemory
blankLogMemory = [(String, LogMessage)] -> LogMemory
LogMemory []
rememberOutputPoint :: FilePath -> LogMessage -> LogMemory -> LogMemory
rememberOutputPoint :: String -> LogMessage -> LogMemory -> LogMemory
rememberOutputPoint String
logPath LogMessage
logMsg LogMemory
oldLogMem =
[(String, LogMessage)] -> LogMemory
LogMemory ([(String, LogMessage)] -> LogMemory)
-> [(String, LogMessage)] -> LogMemory
forall a b. (a -> b) -> a -> b
$
Int -> [(String, LogMessage)] -> [(String, LogMessage)]
forall a. Int -> [a] -> [a]
take Int
50 ([(String, LogMessage)] -> [(String, LogMessage)])
-> [(String, LogMessage)] -> [(String, LogMessage)]
forall a b. (a -> b) -> a -> b
$
(String
logPath, LogMessage
logMsg) (String, LogMessage)
-> [(String, LogMessage)] -> [(String, LogMessage)]
forall a. a -> [a] -> [a]
: ((String, LogMessage) -> Bool)
-> [(String, LogMessage)] -> [(String, LogMessage)]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(/=) String
logPath (String -> Bool)
-> ((String, LogMessage) -> String) -> (String, LogMessage) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, LogMessage) -> String
forall a b. (a, b) -> a
fst) (LogMemory -> [(String, LogMessage)]
logMem LogMemory
oldLogMem)
memoryOfOutputPath :: FilePath -> LogMemory -> Maybe LogMessage
memoryOfOutputPath :: String -> LogMemory -> Maybe LogMessage
memoryOfOutputPath String
p = String -> [(String, LogMessage)] -> Maybe LogMessage
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
p ([(String, LogMessage)] -> Maybe LogMessage)
-> (LogMemory -> [(String, LogMessage)])
-> LogMemory
-> Maybe LogMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogMemory -> [(String, LogMessage)]
logMem
data LogThreadState =
LogThreadState { LogThreadState -> Maybe (String, Handle)
logThreadDestination :: Maybe (FilePath, Handle)
, LogThreadState -> BChan MHEvent
logThreadEventChan :: BChan MHEvent
, LogThreadState -> TChan LogCommand
logThreadCommandChan :: STM.TChan LogCommand
, LogThreadState -> Seq LogMessage
logThreadMessageBuffer :: Seq.Seq LogMessage
, LogThreadState -> Int
logThreadMaxBufferSize :: Int
, LogThreadState -> LogMemory
logPreviousStopPoint :: LogMemory
}
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 { logManagerCommandChannel :: TChan LogCommand
logManagerCommandChannel = TChan LogCommand
chan
, logManagerHandle :: Async ()
logManagerHandle = Async ()
self
}
LogManager -> IO LogManager
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return LogManager
mgr
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
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 { logThreadDestination :: Maybe (String, Handle)
logThreadDestination = Maybe (String, 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
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 a. IO a -> StateT LogThreadState IO a
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 :: String -> Handle -> IO ()
putMarkerMessage String
msg Handle
h = do
UTCTime
now <- IO UTCTime
getCurrentTime
Handle -> String -> IO ()
hPutStrLn Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"[" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTCTime -> String
forall a. Show a => a -> String
show UTCTime
now String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"] " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg
putLogEndMarker :: Handle -> IO ()
putLogEndMarker :: Handle -> IO ()
putLogEndMarker = String -> Handle -> IO ()
putMarkerMessage String
"<<< Logging end >>>"
putLogStartMarker :: Handle -> IO ()
putLogStartMarker :: Handle -> IO ()
putLogStartMarker = String -> Handle -> IO ()
putMarkerMessage String
"<<< Logging start >>>"
finishLog :: BChan MHEvent -> FilePath -> Handle -> StateT LogThreadState IO ()
finishLog :: BChan MHEvent -> String -> Handle -> StateT LogThreadState IO ()
finishLog BChan MHEvent
eventChan String
oldPath Handle
oldHandle = do
IO () -> StateT LogThreadState IO ()
forall a. IO a -> StateT LogThreadState IO a
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
$ String -> InternalEvent
LoggingStopped String
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)
stops :: LogMemory
stops = String -> LogMessage -> LogMemory -> LogMemory
rememberOutputPoint String
oldPath LogMessage
lastLm (LogMemory -> LogMemory) -> LogMemory -> LogMemory
forall a b. (a -> b) -> a -> b
$ LogThreadState -> LogMemory
logPreviousStopPoint LogThreadState
s
in LogThreadState
s { logThreadDestination = Nothing
, logPreviousStopPoint = stops
}
stopLogOutput :: StateT LogThreadState IO ()
stopLogOutput :: StateT LogThreadState IO ()
stopLogOutput = do
Maybe (String, Handle)
oldDest <- (LogThreadState -> Maybe (String, Handle))
-> StateT LogThreadState IO (Maybe (String, Handle))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LogThreadState -> Maybe (String, Handle)
logThreadDestination
case Maybe (String, Handle)
oldDest of
Maybe (String, Handle)
Nothing -> () -> StateT LogThreadState IO ()
forall a. a -> StateT LogThreadState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (String
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 -> String -> Handle -> StateT LogThreadState IO ()
finishLog BChan MHEvent
eventChan String
oldPath Handle
oldHandle
handleLogCommand :: LogCommand -> StateT LogThreadState IO Bool
handleLogCommand :: LogCommand -> StateT LogThreadState IO Bool
handleLogCommand (LogSnapshot String
path) = 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
Maybe (String, Handle)
dest <- (LogThreadState -> Maybe (String, Handle))
-> StateT LogThreadState IO (Maybe (String, Handle))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LogThreadState -> Maybe (String, Handle)
logThreadDestination
let shouldWrite :: Bool
shouldWrite = case Maybe (String, Handle)
dest of
Maybe (String, Handle)
Nothing -> Bool
True
Just (String
curPath, Handle
_) -> String
curPath String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
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 a. IO a -> StateT LogThreadState IO a
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
$ String -> IOMode -> IO Handle
openFile String
path IOMode
AppendMode
case Either SomeException Handle
result of
Left (SomeException
e::SomeException) -> do
IO () -> StateT LogThreadState IO ()
forall a. IO a -> StateT LogThreadState IO a
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
$ String -> String -> InternalEvent
LogSnapshotFailed String
path (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
Right Handle
handle -> do
String -> Handle -> StateT LogThreadState IO ()
flushLogMessageBuffer String
path Handle
handle
IO () -> StateT LogThreadState IO ()
forall a. IO a -> StateT LogThreadState IO a
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 a. IO a -> StateT LogThreadState IO a
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
$ String -> InternalEvent
LogSnapshotSucceeded String
path
Bool -> StateT LogThreadState IO Bool
forall a. a -> StateT LogThreadState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
handleLogCommand LogCommand
GetLogDestination = do
Maybe (String, Handle)
dest <- (LogThreadState -> Maybe (String, Handle))
-> StateT LogThreadState IO (Maybe (String, Handle))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LogThreadState -> Maybe (String, 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 a. IO a -> StateT LogThreadState IO a
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 String -> InternalEvent
LogDestination (Maybe String -> InternalEvent) -> Maybe String -> InternalEvent
forall a b. (a -> b) -> a -> b
$ (String, Handle) -> String
forall a b. (a, b) -> a
fst ((String, Handle) -> String)
-> Maybe (String, Handle) -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (String, Handle)
dest
Bool -> StateT LogThreadState IO Bool
forall a. a -> StateT LogThreadState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
handleLogCommand LogCommand
ShutdownLogging = do
StateT LogThreadState IO ()
stopLogOutput
Bool -> StateT LogThreadState IO Bool
forall a. a -> StateT LogThreadState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
handleLogCommand LogCommand
StopLogging = do
StateT LogThreadState IO ()
stopLogOutput
Bool -> StateT LogThreadState IO Bool
forall a. a -> StateT LogThreadState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
handleLogCommand (LogToFile String
newPath) = 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
Maybe (String, Handle)
oldDest <- (LogThreadState -> Maybe (String, Handle))
-> StateT LogThreadState IO (Maybe (String, Handle))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LogThreadState -> Maybe (String, Handle)
logThreadDestination
Bool
shouldChange <- case Maybe (String, Handle)
oldDest of
Maybe (String, Handle)
Nothing ->
Bool -> StateT LogThreadState IO Bool
forall a. a -> StateT LogThreadState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Just (String
oldPath, Handle
_) ->
Bool -> StateT LogThreadState IO Bool
forall a. a -> StateT LogThreadState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
oldPath String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
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 a. IO a -> StateT LogThreadState IO a
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
$ String -> IOMode -> IO Handle
openFile String
newPath IOMode
AppendMode
case Either SomeException Handle
result of
Left (SomeException
e::SomeException) -> IO () -> StateT LogThreadState IO ()
forall a. IO a -> StateT LogThreadState IO a
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 :: String
msg = String
"Error in log thread: could not open " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
newPath String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
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
$ String -> String -> InternalEvent
LogStartFailed String
newPath String
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 = Just (newPath, handle) }
String -> Handle -> StateT LogThreadState IO ()
flushLogMessageBuffer String
newPath Handle
handle
IO () -> StateT LogThreadState IO ()
forall a. IO a -> StateT LogThreadState IO a
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 a. IO a -> StateT LogThreadState IO a
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
$ String -> InternalEvent
LoggingStarted String
newPath
Bool -> StateT LogThreadState IO Bool
forall a. a -> StateT LogThreadState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
handleLogCommand (LogAMessage LogMessage
lm) = do
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 =
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
(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 = addMessageToBuffer (logThreadMessageBuffer s) }
Maybe (String, Handle)
dest <- (LogThreadState -> Maybe (String, Handle))
-> StateT LogThreadState IO (Maybe (String, Handle))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LogThreadState -> Maybe (String, Handle)
logThreadDestination
case Maybe (String, Handle)
dest of
Maybe (String, Handle)
Nothing -> () -> StateT LogThreadState IO ()
forall a. a -> StateT LogThreadState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (String
_, Handle
handle) -> IO () -> StateT LogThreadState IO ()
forall a. IO a -> StateT LogThreadState IO a
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 a. a -> StateT LogThreadState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
hPutLogMessage :: Handle -> LogMessage -> IO ()
hPutLogMessage :: Handle -> LogMessage -> IO ()
hPutLogMessage Handle
handle (LogMessage {Maybe LogContext
Text
UTCTime
LogCategory
logMessageText :: Text
logMessageContext :: Maybe LogContext
logMessageCategory :: LogCategory
logMessageTimestamp :: UTCTime
logMessageText :: LogMessage -> Text
logMessageContext :: LogMessage -> Maybe LogContext
logMessageCategory :: LogMessage -> LogCategory
logMessageTimestamp :: LogMessage -> UTCTime
..}) = do
Handle -> String -> IO ()
hPutStr Handle
handle (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"[" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UTCTime -> String
forall a. Show a => a -> String
show UTCTime
logMessageTimestamp String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"] "
Handle -> String -> IO ()
hPutStr Handle
handle (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"[" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> LogCategory -> String
forall a. Show a => a -> String
show LogCategory
logMessageCategory String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"] "
case Maybe LogContext
logMessageContext of
Maybe LogContext
Nothing -> Handle -> String -> IO ()
hPutStr Handle
handle String
"[*] "
Just LogContext
c -> Handle -> String -> IO ()
hPutStr Handle
handle (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"[" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> LogContext -> String
forall a. Show a => a -> String
show LogContext
c String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"] "
Handle -> String -> IO ()
hPutStrLn Handle
handle (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
logMessageText
flushLogMessageBuffer :: FilePath -> Handle -> StateT LogThreadState IO ()
flushLogMessageBuffer :: String -> Handle -> StateT LogThreadState IO ()
flushLogMessageBuffer String
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 <- String -> LogMemory -> Maybe LogMessage
memoryOfOutputPath String
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 ->
Seq LogMessage -> StateT LogThreadState IO ()
forall {m :: * -> *}. MonadIO m => Seq LogMessage -> m ()
dumpBuf Seq LogMessage
buf
Just LogMessage
lm ->
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
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 a. IO a -> StateT LogThreadState IO a
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 -> String -> IO ()
hPutStrLn Handle
handle (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ UTCTime -> String -> String
forall {a}. Show a => a -> String -> String
mkMsg (LogMessage -> UTCTime
logMessageTimestamp LogMessage
firstM)
String
"<<< Potentially missing log messages here... >>>"
Seq LogMessage -> StateT LogThreadState IO ()
forall {m :: * -> *}. MonadIO m => Seq LogMessage -> m ()
dumpBuf Seq LogMessage
unseen
where
mkMsg :: a -> String -> String
mkMsg a
t String
m = String
"[" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
t String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"] " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
m
dumpBuf :: Seq LogMessage -> m ()
dumpBuf Seq LogMessage
buf = IO () -> m ()
forall a. IO a -> m a
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 -> String -> IO ()
hPutStrLn Handle
handle (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ UTCTime -> String -> String
forall {a}. Show a => a -> String -> String
mkMsg (LogMessage -> UTCTime
logMessageTimestamp LogMessage
firstLm)
String
"<<< 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 -> String -> IO ()
hPutStrLn Handle
handle (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ UTCTime -> String -> String
forall {a}. Show a => a -> String -> String
mkMsg (LogMessage -> UTCTime
logMessageTimestamp LogMessage
lastLm)
String
"<<< Log message buffer end >>>"
Handle -> IO ()
hFlush Handle
handle