content: {-# 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
  