{-# 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 { logMem :: [(FilePath, LogMessage)] }

blankLogMemory :: LogMemory
blankLogMemory = 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 logPath logMsg oldLogMem =
  LogMemory $
  take 50 $ -- upper limit on number of logpath+message memories retained
  (logPath, logMsg) : filter ((/=) logPath . fst) (logMem 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 p = lookup p . logMem

-- | The state of the logging thread.
data LogThreadState =
    LogThreadState { logThreadDestination :: Maybe (FilePath, Handle)
                   -- ^ The logging thread's active logging destination.
                   -- Nothing means log messages are not being written
                   -- anywhere except the internal buffer.
                   , logThreadEventChan :: BChan MHEvent
                   -- ^ The application event channel that we'll use to
                   -- notify of logging events.
                   , logThreadCommandChan :: STM.TChan LogCommand
                   -- ^ The channel on which the logging thread will
                   -- wait for logging commands.
                   , logThreadMessageBuffer :: Seq.Seq LogMessage
                   -- ^ The internal bounded log message buffer.
                   , logThreadMaxBufferSize :: Int
                   -- ^ The size bound of the logThreadMessageBuffer.
                   , 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 eventChan maxBufferSize = do
    chan <- STM.newTChanIO
    self <- startLoggingThread eventChan chan maxBufferSize
    let mgr = LogManager { logManagerCommandChannel = chan
                         , logManagerHandle = self
                         }
    return mgr

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

-- | The logging thread.
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

-- | Get the next pending log thread command.
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

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

-- | Emit a log start marker to the file.
putLogStartMarker :: Handle -> IO ()
putLogStartMarker = putMarkerMessage "<<< 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 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) -- n.b. putLogEndMarker ensures buf not empty
          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

-- | Handle a single logging command.
handleLogCommand :: LogCommand -> StateT LogThreadState IO Bool
handleLogCommand (LogSnapshot 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.
    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
    -- GetLogDestination: the application asked us to provide the
    -- current log destination.
    dest <- gets logThreadDestination
    eventChan <- gets logThreadEventChan
    liftIO $ writeBChan eventChan $ IEvent $ LogDestination $ fst <$> dest
    return True
handleLogCommand ShutdownLogging = do
    -- ShutdownLogging: if we were logging to a file, close it. Then
    -- unlock the shutdown lock.
    stopLogOutput
    return False
handleLogCommand StopLogging = do
    -- StopLogging: if we were logging to a file, close it and notify
    -- the application. Otherwise do nothing.
    stopLogOutput
    return True
handleLogCommand (LogToFile 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.
    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
    -- 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.
    maxBufSize <- gets logThreadMaxBufferSize

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

    -- Append the message to the internal buffer, maintaining the bound
    -- on the internal buffer size.
    modify $ \s -> s { logThreadMessageBuffer = addMessageToBuffer (logThreadMessageBuffer s) }

    -- If we have an active log destination, write the message to the
    -- output file.
    dest <- gets logThreadDestination
    case dest of
        Nothing -> return ()
        Just (_, handle) -> liftIO $ do
            hPutLogMessage handle lm
            hFlush handle

    return True

-- | Write a single log message to the output handle.
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

-- | Flush the contents of the internal log message buffer.
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 ->
          -- never logged to this output point before, so dump the
          -- current internal buffer of log messages to the beginning of
          -- the output file.
          dumpBuf buf
        Just 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.takeWhileR (not . (==) lm) buf
              firstM = Seq.index buf 0 -- above ensures that buf is not empty here
          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