{-# 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 { logMem :: [(FilePath, LogMessage)] }
blankLogMemory :: LogMemory
blankLogMemory = LogMemory []
rememberOutputPoint :: FilePath -> LogMessage -> LogMemory -> LogMemory
rememberOutputPoint logPath logMsg oldLogMem =
LogMemory $
take 50 $
(logPath, logMsg) : filter ((/=) logPath . fst) (logMem oldLogMem)
memoryOfOutputPath :: FilePath -> LogMemory -> Maybe LogMessage
memoryOfOutputPath p = lookup p . logMem
data LogThreadState =
LogThreadState { logThreadDestination :: Maybe (FilePath, Handle)
, logThreadEventChan :: BChan MHEvent
, logThreadCommandChan :: STM.TChan LogCommand
, logThreadMessageBuffer :: Seq.Seq LogMessage
, logThreadMaxBufferSize :: Int
, logPreviousStopPoint :: LogMemory
}
newLogManager :: BChan MHEvent -> Int -> IO LogManager
newLogManager eventChan maxBufferSize = do
chan <- STM.newTChanIO
self <- startLoggingThread eventChan chan maxBufferSize
let mgr = LogManager { logManagerCommandChannel = chan
, logManagerHandle = self
}
return mgr
shutdownLogManager :: LogManager -> IO ()
shutdownLogManager mgr = do
STM.atomically $ STM.writeTChan (logManagerCommandChannel mgr) ShutdownLogging
wait $ logManagerHandle mgr
startLoggingThread :: BChan MHEvent -> STM.TChan LogCommand -> Int -> IO (Async ())
startLoggingThread eventChan logChan maxBufferSize = do
let initialState = LogThreadState { logThreadDestination = Nothing
, logThreadEventChan = eventChan
, logThreadCommandChan = logChan
, logThreadMessageBuffer = mempty
, logThreadMaxBufferSize = maxBufferSize
, logPreviousStopPoint = blankLogMemory
}
async $ void $ runStateT logThreadBody initialState
logThreadBody :: StateT LogThreadState IO ()
logThreadBody = do
cmd <- nextLogCommand
continue <- handleLogCommand cmd
when continue logThreadBody
nextLogCommand :: StateT LogThreadState IO LogCommand
nextLogCommand = do
chan <- gets logThreadCommandChan
liftIO $ STM.atomically $ STM.readTChan chan
putMarkerMessage :: String -> Handle -> IO ()
putMarkerMessage msg h = do
now <- getCurrentTime
hPutStrLn h $ "[" <> show now <> "] " <> msg
putLogEndMarker :: Handle -> IO ()
putLogEndMarker = putMarkerMessage "<<< Logging end >>>"
putLogStartMarker :: Handle -> IO ()
putLogStartMarker = putMarkerMessage "<<< Logging start >>>"
finishLog :: BChan MHEvent -> FilePath -> Handle -> StateT LogThreadState IO ()
finishLog eventChan oldPath oldHandle = do
liftIO $ do
putLogEndMarker oldHandle
hClose oldHandle
writeBChan eventChan $ IEvent $ LoggingStopped oldPath
modify $ \s ->
let buf = logThreadMessageBuffer s
lastLm = Seq.index buf (Seq.length buf - 1)
stops = rememberOutputPoint oldPath lastLm $ logPreviousStopPoint s
in s { logThreadDestination = Nothing
, logPreviousStopPoint = stops
}
stopLogOutput :: StateT LogThreadState IO ()
stopLogOutput = do
oldDest <- gets logThreadDestination
case oldDest of
Nothing -> return ()
Just (oldPath, oldHandle) -> do
eventChan <- gets logThreadEventChan
finishLog eventChan oldPath oldHandle
handleLogCommand :: LogCommand -> StateT LogThreadState IO Bool
handleLogCommand (LogSnapshot path) = do
eventChan <- gets logThreadEventChan
dest <- gets logThreadDestination
let shouldWrite = case dest of
Nothing -> True
Just (curPath, _) -> curPath /= path
when shouldWrite $ do
result <- liftIO $ try $ openFile path AppendMode
case result of
Left (e::SomeException) -> do
liftIO $ writeBChan eventChan $ IEvent $ LogSnapshotFailed path (show e)
Right handle -> do
flushLogMessageBuffer path handle
liftIO $ hClose handle
liftIO $ writeBChan eventChan $ IEvent $ LogSnapshotSucceeded path
return True
handleLogCommand GetLogDestination = do
dest <- gets logThreadDestination
eventChan <- gets logThreadEventChan
liftIO $ writeBChan eventChan $ IEvent $ LogDestination $ fst <$> dest
return True
handleLogCommand ShutdownLogging = do
stopLogOutput
return False
handleLogCommand StopLogging = do
stopLogOutput
return True
handleLogCommand (LogToFile newPath) = do
eventChan <- gets logThreadEventChan
oldDest <- gets logThreadDestination
shouldChange <- case oldDest of
Nothing ->
return True
Just (oldPath, _) ->
return (oldPath /= newPath)
when shouldChange $ do
result <- liftIO $ try $ openFile newPath AppendMode
case result of
Left (e::SomeException) -> liftIO $ do
let msg = "Error in log thread: could not open " <> show newPath <>
": " <> show e
writeBChan eventChan $ IEvent $ LogStartFailed newPath msg
Right handle -> do
stopLogOutput
modify $ \s -> s { logThreadDestination = Just (newPath, handle) }
flushLogMessageBuffer newPath handle
liftIO $ putLogStartMarker handle
liftIO $ writeBChan eventChan $ IEvent $ LoggingStarted newPath
return True
handleLogCommand (LogAMessage lm) = do
maxBufSize <- gets logThreadMaxBufferSize
let addMessageToBuffer s =
let newSeq = s Seq.|> lm
toDrop = Seq.length s - maxBufSize
in Seq.drop toDrop newSeq
modify $ \s -> s { logThreadMessageBuffer = addMessageToBuffer (logThreadMessageBuffer s) }
dest <- gets logThreadDestination
case dest of
Nothing -> return ()
Just (_, handle) -> liftIO $ do
hPutLogMessage handle lm
hFlush handle
return True
hPutLogMessage :: Handle -> LogMessage -> IO ()
hPutLogMessage handle (LogMessage {..}) = do
hPutStr handle $ "[" <> show logMessageTimestamp <> "] "
hPutStr handle $ "[" <> show logMessageCategory <> "] "
case logMessageContext of
Nothing -> hPutStr handle "[*] "
Just c -> hPutStr handle $ "[" <> show c <> "] "
hPutStrLn handle $ T.unpack logMessageText
flushLogMessageBuffer :: FilePath -> Handle -> StateT LogThreadState IO ()
flushLogMessageBuffer pathOfHandle handle = do
buf <- gets logThreadMessageBuffer
when (not $ Seq.null buf) $ do
lastPoint <- memoryOfOutputPath pathOfHandle <$> gets logPreviousStopPoint
case lastPoint of
Nothing ->
dumpBuf buf
Just lm ->
let unseen = Seq.takeWhileR (not . (==) lm) buf
firstM = Seq.index buf 0
in do when (Seq.length buf == Seq.length unseen) $ liftIO $
hPutStrLn handle $ mkMsg (logMessageTimestamp firstM)
"<<< Potentially missing log messages here... >>>"
dumpBuf unseen
where
mkMsg t m = "[" <> show t <> "] " <> m
dumpBuf buf = liftIO $ do
let firstLm = Seq.index buf 0
lastLm = Seq.index buf (Seq.length buf - 1)
hPutStrLn handle $ mkMsg (logMessageTimestamp firstLm)
"<<< Log message buffer begin >>>"
forM_ buf (hPutLogMessage handle)
hPutStrLn handle $ mkMsg (logMessageTimestamp lastLm)
"<<< Log message buffer end >>>"
hFlush handle