{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module Cardano.RTView.ErrorBuffer
    ( ErrorBuffer
    , readErrorBuffer
    , effectuate
    , realize
    , unrealize
    ) where

import           Cardano.Prelude hiding (modifyMVar, newMVar, readMVar)

import           Control.Concurrent.MVar (MVar, modifyMVar, newMVar, readMVar)
import qualified Control.Concurrent.STM.TBQueue as TBQ

import           Data.Aeson (FromJSON)
import qualified Data.Text.IO as TIO
import           System.IO (stderr)

import           Cardano.BM.Data.Backend (BackendKind (..), IsBackend (..), IsEffectuator (..))
import           Cardano.BM.Data.LogItem (LOContent (..), LOMeta (..), LogObject (..), LoggerName)
import           Cardano.BM.Data.Severity (Severity (..))

-- | All |LogObject|s accepted by |TraceAcceptor| plugin
--   will be decoded and traced to 'cardano-rt-view.acceptor'.
--   Because of RView configuration all these |LogObject|s
--   will be sent to |LogBufferBK| and |ErrorBufferBK|,
--   but |ErrorBufferBK| is storing only errors.
--   Later NodesState.Updater will extract errors from |ErrorBufferBK|
--   and display them in UI ("Errors" tab).
newtype ErrorBuffer a = ErrorBuffer
  { ErrorBuffer a -> MVar (ErrorBufferInternal a)
getErrBuf :: MVar (ErrorBufferInternal a)
  }

newtype ErrorBufferInternal a
  = ErrorBufferInternal
      { ErrorBufferInternal a -> TBQueue (LoggerName, LogObject a)
errQueue :: TBQ.TBQueue (LoggerName, LogObject a)
      }

-- | Once we read the current content of the queue, it should be cleaned.
readErrorBuffer :: ErrorBuffer a -> IO [(LoggerName, LogObject a)]
readErrorBuffer :: ErrorBuffer a -> IO [(LoggerName, LogObject a)]
readErrorBuffer ErrorBuffer a
buffer =
  MVar (ErrorBufferInternal a)
-> (ErrorBufferInternal a
    -> IO (ErrorBufferInternal a, [(LoggerName, LogObject a)]))
-> IO [(LoggerName, LogObject a)]
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (ErrorBuffer a -> MVar (ErrorBufferInternal a)
forall a. ErrorBuffer a -> MVar (ErrorBufferInternal a)
getErrBuf ErrorBuffer a
buffer) ((ErrorBufferInternal a
  -> IO (ErrorBufferInternal a, [(LoggerName, LogObject a)]))
 -> IO [(LoggerName, LogObject a)])
-> (ErrorBufferInternal a
    -> IO (ErrorBufferInternal a, [(LoggerName, LogObject a)]))
-> IO [(LoggerName, LogObject a)]
forall a b. (a -> b) -> a -> b
$ \ErrorBufferInternal a
currentBuffer -> do
    [(LoggerName, LogObject a)]
loList <- STM [(LoggerName, LogObject a)] -> IO [(LoggerName, LogObject a)]
forall a. STM a -> IO a
atomically (STM [(LoggerName, LogObject a)] -> IO [(LoggerName, LogObject a)])
-> STM [(LoggerName, LogObject a)]
-> IO [(LoggerName, LogObject a)]
forall a b. (a -> b) -> a -> b
$ TBQueue (LoggerName, LogObject a)
-> STM [(LoggerName, LogObject a)]
forall a. TBQueue a -> STM [a]
TBQ.flushTBQueue (ErrorBufferInternal a -> TBQueue (LoggerName, LogObject a)
forall a.
ErrorBufferInternal a -> TBQueue (LoggerName, LogObject a)
errQueue ErrorBufferInternal a
currentBuffer)
    -- LogObjects are flushed, clean it up.
    TBQueue (LoggerName, LogObject a)
queue <- STM (TBQueue (LoggerName, LogObject a))
-> IO (TBQueue (LoggerName, LogObject a))
forall a. STM a -> IO a
atomically (STM (TBQueue (LoggerName, LogObject a))
 -> IO (TBQueue (LoggerName, LogObject a)))
-> STM (TBQueue (LoggerName, LogObject a))
-> IO (TBQueue (LoggerName, LogObject a))
forall a b. (a -> b) -> a -> b
$ Natural -> STM (TBQueue (LoggerName, LogObject a))
forall a. Natural -> STM (TBQueue a)
TBQ.newTBQueue Natural
queueMaxSize
    (ErrorBufferInternal a, [(LoggerName, LogObject a)])
-> IO (ErrorBufferInternal a, [(LoggerName, LogObject a)])
forall (m :: * -> *) a. Monad m => a -> m a
return (TBQueue (LoggerName, LogObject a) -> ErrorBufferInternal a
forall a.
TBQueue (LoggerName, LogObject a) -> ErrorBufferInternal a
ErrorBufferInternal TBQueue (LoggerName, LogObject a)
queue, [(LoggerName, LogObject a)]
loList)

instance IsEffectuator ErrorBuffer a where
  effectuate :: ErrorBuffer a -> LogObject a -> IO ()
effectuate ErrorBuffer a
buffer lo :: LogObject a
lo@(LogObject LoggerName
loname LOMeta
lometa LOContent a
locontent) = do
    ErrorBufferInternal a
currentEB <- MVar (ErrorBufferInternal a) -> IO (ErrorBufferInternal a)
forall a. MVar a -> IO a
readMVar (ErrorBuffer a -> MVar (ErrorBufferInternal a)
forall a. ErrorBuffer a -> MVar (ErrorBufferInternal a)
getErrBuf ErrorBuffer a
buffer)
    let queue :: TBQueue (LoggerName, LogObject a)
queue = ErrorBufferInternal a -> TBQueue (LoggerName, LogObject a)
forall a.
ErrorBufferInternal a -> TBQueue (LoggerName, LogObject a)
errQueue ErrorBufferInternal a
currentEB
    Bool
noCapacity <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TBQueue (LoggerName, LogObject a) -> STM Bool
forall a. TBQueue a -> STM Bool
TBQ.isFullTBQueue TBQueue (LoggerName, LogObject a)
queue
    if Bool
noCapacity
      then ErrorBuffer a -> IO ()
forall (t :: * -> *) a. IsEffectuator t a => t a -> IO ()
handleOverflow ErrorBuffer a
buffer
      else Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isError (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
             STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TBQueue (LoggerName, LogObject a)
-> (LoggerName, LogObject a) -> STM ()
forall a. TBQueue a -> a -> STM ()
TBQ.writeTBQueue TBQueue (LoggerName, LogObject a)
queue (LoggerName
"#buffered." LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
loname, LogObject a
lo)
   where
    -- Only Error-messages should be stored in the queue.
    isError :: Bool
isError =
      case LOContent a
locontent of
        LogValue LoggerName
_ Measurable
_ -> Bool
False
        LogError LoggerName
_   -> Bool
True
        LOContent a
_            -> LOMeta -> Severity
severity LOMeta
lometa Severity -> Severity -> Bool
forall a. Ord a => a -> a -> Bool
>= Severity
Error

  handleOverflow :: ErrorBuffer a -> IO ()
handleOverflow ErrorBuffer a
_ = Handle -> LoggerName -> IO ()
TIO.hPutStrLn Handle
stderr LoggerName
"Notice: overflow in ErrorBuffer, dropping log items!"

instance FromJSON a => IsBackend ErrorBuffer a where
  bekind :: ErrorBuffer a -> BackendKind
bekind ErrorBuffer a
_ = LoggerName -> BackendKind
UserDefinedBK LoggerName
"ErrorBufferBK"

  realize :: Configuration -> IO (ErrorBuffer a)
realize Configuration
_ = do
    TBQueue (LoggerName, LogObject a)
queue <- STM (TBQueue (LoggerName, LogObject a))
-> IO (TBQueue (LoggerName, LogObject a))
forall a. STM a -> IO a
atomically (STM (TBQueue (LoggerName, LogObject a))
 -> IO (TBQueue (LoggerName, LogObject a)))
-> STM (TBQueue (LoggerName, LogObject a))
-> IO (TBQueue (LoggerName, LogObject a))
forall a b. (a -> b) -> a -> b
$ Natural -> STM (TBQueue (LoggerName, LogObject a))
forall a. Natural -> STM (TBQueue a)
TBQ.newTBQueue Natural
queueMaxSize
    MVar (ErrorBufferInternal a) -> ErrorBuffer a
forall a. MVar (ErrorBufferInternal a) -> ErrorBuffer a
ErrorBuffer (MVar (ErrorBufferInternal a) -> ErrorBuffer a)
-> IO (MVar (ErrorBufferInternal a)) -> IO (ErrorBuffer a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ErrorBufferInternal a -> IO (MVar (ErrorBufferInternal a))
forall a. a -> IO (MVar a)
newMVar (TBQueue (LoggerName, LogObject a) -> ErrorBufferInternal a
forall a.
TBQueue (LoggerName, LogObject a) -> ErrorBufferInternal a
ErrorBufferInternal TBQueue (LoggerName, LogObject a)
queue)

  unrealize :: ErrorBuffer a -> IO ()
unrealize ErrorBuffer a
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

queueMaxSize :: Natural
queueMaxSize :: Natural
queueMaxSize = Natural
1000