{-# 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 -> [(FilePath, LogMessage)]
logMem :: [(FilePath, LogMessage)] }
blankLogMemory :: LogMemory
blankLogMemory :: LogMemory
blankLogMemory = [(FilePath, LogMessage)] -> LogMemory
LogMemory []
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
$
(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)
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
data LogThreadState =
LogThreadState { LogThreadState -> Maybe (FilePath, 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 :: 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
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 :: 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
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
putLogEndMarker :: Handle -> IO ()
putLogEndMarker :: Handle -> IO ()
putLogEndMarker = FilePath -> Handle -> IO ()
putMarkerMessage FilePath
"<<< Logging end >>>"
putLogStartMarker :: Handle -> IO ()
putLogStartMarker :: Handle -> IO ()
putLogStartMarker = FilePath -> Handle -> IO ()
putMarkerMessage FilePath
"<<< Logging start >>>"
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)
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
handleLogCommand :: LogCommand -> StateT LogThreadState IO Bool
handleLogCommand :: LogCommand -> StateT LogThreadState IO Bool
handleLogCommand (LogSnapshot FilePath
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 (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
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
StateT LogThreadState IO ()
stopLogOutput
Bool -> StateT LogThreadState IO Bool
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 (m :: * -> *) a. Monad m => a -> m a
return Bool
True
handleLogCommand (LogToFile FilePath
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 (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
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 :: Seq LogMessage
logThreadMessageBuffer = Seq LogMessage -> Seq LogMessage
addMessageToBuffer (LogThreadState -> Seq LogMessage
logThreadMessageBuffer LogThreadState
s) }
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
hPutLogMessage :: Handle -> LogMessage -> IO ()
hPutLogMessage :: Handle -> LogMessage -> IO ()
hPutLogMessage Handle
handle (LogMessage {Maybe LogContext
Text
UTCTime
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
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 ->
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 (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